Building a web library using super hard Haskell
Marcin Rzeźnicki
- (disillusioned) Scala programmer till the beginning of 2020
- started learning Haskell in January
- in the trenches since almost the beginning of the century :-)
- two libs on Hackage/Stackage: stackcollapse-ghc and hspec-tables
What is hard Haskell? Opposite of simple Haskell!
The Simple Haskell initiative (https://www.simplehaskell.org)
- There are as many opinions on what constitutes Simple Haskell as there are people who have them.
- (...) the value that Haskell98 has to offer through features like:
- Pure Functions
- Sum and Product Types
- Type Classes
- Polymorphism
You get most of the benefit just using newtypes, data, and functions - Don Stewart
What is hard Haskell? Opposite of simple Haskell!
Hard Haskell must therefore constitute of:
- GADTs
- Higher-rank polymorphism
- Generics
- Type applications (only non-ambiguous types!)
- Type kinds and datatype promotions
- Type-level programming of any kind: type/data families, type-level literals, equality constraints (!)
- Kind polymorphism
- FFI (!)
Are these that hard? 🤔
(Thinking with) types got you
You can honestly stop watching this talk and go read it
HList in Scala vs Haskell
sealed trait HList extends Product with Serializable
final case class ::[+H, +T <: HList](head : H, tail : T) extends HList
sealed trait HNil extends HList {
def ::[H](h: H): H :: HNil = new ::(h, this)
}
case object HNil extends HNil
data HList (l::[*]) where
HNil :: HList '[]
HCons :: e -> HList l -> HList (e ': l)
Problem: JWT
Problem: JWT
Problem: JWT
Problem: JWT
Why is (Map Text Value) bad?
- dependency on Aeson
- wrong abstraction - raw JSON instead of logical value
- I know what's in there!
- I know the types!
- I have to write the code to decode it ...
- and deal with the possible errors
Problem: JWT
Design a solution
- replace Map with more expressive type(s)
- use FFI for low level stuff (encryption, JSON)
- eliminate low-level details from user's code
You can't do that in "Simple" Haskell.
FFI == impure; no Map == type-level hackery
Is it too hard/fancy? 🤔
Problem: FFI
library
import: common-options
hs-source-dirs: src
extra-libraries: jansson
jwt
It's time to add some bindings!
Cheatsheet: FFI
{-# LANGUAGE ForeignFunctionInterface #-}
import Foreign
import Foreign.C.Types
import Foreign.C.String
newtype JwtT = JwtT (ForeignPtr JwtT)
type PJwtT = Ptr JwtT
foreign import ccall unsafe "jwt.h jwt_new" c_jwt_new :: Ptr PJwtT -> IO CInt
foreign import ccall unsafe "jwt.h &jwt_free" p_jwt_free :: FunPtr (PJwtT -> IO ())
foreign import ccall unsafe "jwt.h jwt_add_grant" c_jwt_add_grant :: PJwtT -> CString -> CString -> IO CInt
foreign import ccall unsafe "jwt.h jwt_add_grants_json" c_jwt_add_grants_json :: PJwtT -> CString -> IO CInt
foreign import ccall unsafe "jwt.h jwt_get_grant" c_jwt_get_grant :: PJwtT -> CString -> IO CString
foreign import ccall unsafe "jwt.h jwt_get_grants_json" c_jwt_get_grants_json :: PJwtT -> CString -> IO CString
foreign import ccall unsafe "jwt.h jwt_get_alg" c_jwt_get_alg :: PJwtT -> JwtAlgT
foreign import ccall unsafe "jwt.h jwt_set_alg" c_jwt_set_alg :: PJwtT -> JwtAlgT -> CString -> CInt -> IO CInt
foreign import ccall unsafe "jwt.h jwt_add_header" c_jwt_add_header :: PJwtT -> CString -> CString -> IO CInt
foreign import ccall unsafe "jwt.h jwt_get_header" c_jwt_get_header :: PJwtT -> CString -> IO CString
foreign import ccall unsafe "jwt.h jwt_encode_str" c_jwt_encode_str :: PJwtT -> IO CString
foreign import ccall unsafe "jwt.h jwt_decode" c_jwt_decode :: Ptr PJwtT -> CString -> CString -> CInt -> IO CInt
wrapPtr :: PJwtT -> IO JwtT
wrapPtr = coerce . newForeignPtr p_jwt_free
Cheatsheet: FFI / hsc
{-# LANGUAGE CPP, ForeignFunctionInterface #-}
{-# LANGUAGE DerivingStrategies #-}
import Foreign.C.Types
newtype JwtAlgT = JwtAlg CInt
deriving stock Eq
#include <jwt.h>
#{enum JwtAlgT, JwtAlg
, JWT_ALG_NONE
, JWT_ALG_HS256
, JWT_ALG_HS384
, JWT_ALG_HS512
, JWT_ALG_RS256
, JWT_ALG_RS384
, JWT_ALG_RS512
, JWT_ALG_ES256
, JWT_ALG_ES384
, JWT_ALG_ES512
, JWT_ALG_TERM
}
Cheatsheet: FFI / bad parts
foreign import ccall unsafe "jansson.h json_typeof" c_json_typeof :: Ptr JsonT -> JsonType
foreign import ccall unsafe "jansson.h &json_decref" p_json_decref :: FunPtr (Ptr JsonT -> IO())
#define json_typeof(json) ((json)->type)
static JSON_INLINE void json_decref(json_t *json) {
if (json && json->refcount != (size_t)-1 && JSON_INTERNAL_DECREF(json) == 0)
json_delete(json);
}
~/.stack-work/dist/x86_64-linux-tinfo6/Cabal-3.0.1.0/build/libHSlibjwt-typed-0.1-GeisNnJh3LR3MSw1wFpq51.a(Json.o):function libjwtzmtypedzm0zi1zmGeisNnJh3LR3MSw1wFpq51_LibjwtziFFIziJson_zdwunsafeJsonArrayForeachM_info: error: undefined reference to 'json_decref'
~/.stack-work/dist/x86_64-linux-tinfo6/Cabal-3.0.1.0/build/libHSlibjwt-typed-0.1-GeisNnJh3LR3MSw1wFpq51.a(Json.o):function libjwtzmtypedzm0zi1zmGeisNnJh3LR3MSw1wFpq51_LibjwtziFFIziJson_zdwunsafeJsonArrayForeachM_info: error: undefined reference to 'json_typeof'
Cheatsheet: FFI / bad parts
foreign import ccall unsafe "hs_json_typeof" c_json_typeof :: Ptr JsonT -> JsonType
foreign import ccall unsafe "&hs_json_decref" p_json_decref :: FunPtr (Ptr JsonT -> IO())
#include <jansson.h>
void hs_json_decref (json_t* json) {
json_decref(json);
}
int hs_json_typeof (const json_t* json) {
return json_typeof(json);
}
Sometimes you just have to write a bit of C
library
import: common-options
hs-source-dirs: src
c-sources: src/cbits/HsJansson.c
extra-libraries: jansson
jwt
How-to: FFI
With the bindings in place, write a nice (simple) glue modules for low-level stuff. Basically, a simple "imperativish" code you'd write in C (but in Haskell)
mkJwtT :: IO JwtT
mkJwtT = alloca $ \ptr -> do
res <- c_jwt_new ptr
if res == 0 then wrapPtr =<< peek ptr else throwLibjwt "jwt_new" res
jwtDecode :: Maybe ByteString -> ByteString -> IO JwtT
jwtDecode maybeKey token =
maybe ($ (nullPtr, 0)) unsafeUseAsCStringLen maybeKey
$ \(p_key, key_len) -> useAsCString token $ \p_token -> alloca $ \ret -> do
res <- c_jwt_decode ret p_token p_key $ fromIntegral key_len
if res == 0 then wrapPtr =<< peek ret else throwLibjwt "jwt_decode" res
jwtEncode :: JwtT -> JwtIO ByteString
jwtEncode (JwtT pjwt_t) =
JIO
$ withForeignPtr pjwt_t
$ unsafePackMallocCString
<=< throwErrnoIfNull "jwt_encode_str"
. c_jwt_encode_str
How-to: FFI
Or even better - wrap it in a "custom" IO so that nobody calls putStrLn in the inappropriate places
newtype JwtIO a = JIO (IO a)
deriving newtype (Functor, Applicative, Monad, MonadThrow, MonadCatch)
mkJwtT :: JwtIO JwtT
mkJwtT = JIO $ alloca $ \ptr -> do
res <- c_jwt_new ptr
if res == 0 then wrapPtr =<< peek ptr else throwLibjwt "jwt_new" res
jwtDecode :: Maybe ByteString -> ByteString -> JwtIO JwtT
jwtDecode maybeKey token =
JIO
$ maybe ($ (nullPtr, 0)) unsafeUseAsCStringLen maybeKey
$ \(p_key, key_len) -> useAsCString token $ \p_token -> alloca $ \ret -> do
res <- c_jwt_decode ret p_token p_key $ fromIntegral key_len
if res == 0
then wrapPtr =<< peek ret
else throwLibjwt "jwt_decode" res
-- etc
Highlights: RULES pragma
Let's use our domain knowledge: we'll be dealing with lots of constant string (key names). And type-level literals, which we'll use later, are also "constants". And so it happens that they're valid C strings 🤔 ... 💡
addHeader :: String -> ByteString -> JwtT -> JwtIO ()
addHeader h val (JwtT pjwt_t) =
JIO $ useAsCString val $ \p_val -> withForeignPtr pjwt_t $ \jwt ->
withCAString h $ \ph -> do
res <- c_jwt_add_header jwt ph p_val
if res == 0 then return () else throwLibjwt "jwt_add_jeader" res
getGrant :: String -> JwtT -> JwtIO (Maybe ByteString)
getGrant grant (JwtT pjwt_t) = JIO $ withForeignPtr pjwt_t $ \jwt ->
withCAString grant $ \p_grant -> do
val <- c_jwt_get_grant jwt p_grant
if val == nullPtr then return Nothing else Just <$> packCString val
Highlights: RULES pragma
Write the "unsafe" versions that can only work with an already valid C-pointer (Addr# is the GHC term for a valid C pointer) and rewrite rules that tell the re-writer when to use them
unsafeAddHeader :: Addr# -> ByteString -> JwtT -> JwtIO ()
unsafeAddHeader p_header val (JwtT pjwt_t) =
JIO $ useAsCString val $ \p_val -> withForeignPtr pjwt_t $ \jwt -> do
res <- c_jwt_add_header jwt (Ptr p_header) p_val
if res == 0 then return () else throwLibjwt "jwt_add_header" res
unsafeGetGrant :: Addr# -> JwtT -> JwtIO (Maybe ByteString)
unsafeGetGrant p_grant (JwtT pjwt_t) = JIO $ withForeignPtr pjwt_t $ \jwt -> do
val <- c_jwt_get_grant jwt $ Ptr p_grant
if val == nullPtr then return Nothing else Just <$> packCString val
{-# RULES
"getGrant/unsafeGetGrant" forall s . getGrant (unpackCString# s) = unsafeGetGrant s
"addHeader/unsafeAddHeader" forall s . addHeader (unpackCString# s) = unsafeAddHeader s #-}
{-# INLINE [0] getGrant #-}
{-# INLINE [0] addHeader #-} -- these are needed to reliably fire rules
Cheatsheet: RULES pragma
How to inspect if rules are fired? I use -ddump-simpl-stats GHC option
238 RuleFired
...
4 getGrant/unsafeGetGrant
3 addGrant/unsafeAddGrant
3 addGrantInt64/unsafeAddGrantInt64
3 getGrantInt64/unsafeGetGrantInt64
How-To: Encoding structures
type EncodeResult = JwtIO ()
class ClaimEncoder t where
encodeClaim :: String -> t -> JwtT -> EncodeResult
instance ClaimEncoder ByteString where
encodeClaim = addGrant -- call C
instance ClaimEncoder Bool where
encodeClaim = addGrantBool -- call C
instance ClaimEncoder Int where
encodeClaim = addGrantInt -- call C
instance ClaimEncoder a => ClaimEncoder (Maybe a) where
encodeClaim name (Just val) = encodeClaim name val
encodeClaim _ Nothing = nullEncode
contraEncode
:: ClaimEncoder a => (b -> a) -> String -> b -> JwtT -> EncodeResult
contraEncode f name = encodeClaim name . f
-- adding new types is easy
instance ClaimEncoder UUID where
encodeClaim = contraEncode UUID.toASCIIBytes
How-To: Encoding more complex structures
class Encode c where
encode :: c -> JwtT -> EncodeResult
data Payload = ClaimsSet { iss :: Iss
, sub :: Sub
, aud :: Aud
, exp :: Exp
, nbf :: Nbf
, iat :: Iat
, jti :: Jti
, privateClaims :: _ -- still don't know
}
instance Encode Sub where
encode (Sub sub) = encodeClaim "sub" sub -- this is where RULES kick-in
instance Encode Payload where
encode ClaimsSet { iss, sub, aud, exp, nbf, iat, jti, privateClaims } jwt =
encode iss jwt
>> encode sub jwt
>> encode aud jwt
>> encode exp jwt
>> encode nbf jwt
>> encode iat jwt
>> encode jti jwt
>> _ -- encode privateClaims jwt (how ?)
Problem: unsafePerform(Jwt)IO
newtype Encoded t = MkEncoded { getToken :: ByteString }
signJwt ::Jwt -> Encoded Jwt
signJwt it = MkEncoded $ _
where
signTokenJwtIo = do
jwt <- mkJwtT
encode it jwt
jwtEncode jwt
-- where we defined JwtIO
unsafePerformJwtIO :: JwtIO a -> a
unsafePerformJwtIO (JIO io) = unsafePerformIO io
Used unwisely, this function lets us sidestep all safety guarantees the Haskell type system provides, inserting arbitrary side effects into a Haskell program, anywhere. The dangers in doing this are significant: we can break optimizations, modify arbitrary locations in memory, remove files on the user's machine, or launch nuclear missiles from our Fibonacci sequences. So why does this function exist at all? -
Real World Haskell
How-To: unsafePerform(Jwt)IO
newtype Encoded t = MkEncoded { getToken :: ByteString }
signJwt ::Jwt -> Encoded Jwt
signJwt it = MkEncoded $ unsafePerformJwtIO signTokenJwtIo
where
signTokenJwtIo = do
jwt <- mkJwtT
encode it jwt
jwtEncode jwt
{-# NOINLINE signJwt #-} -- prevent escaping
-- where we defined JwtIO
unsafePerformJwtIO :: JwtIO a -> a
unsafePerformJwtIO (JIO io) = unsafePerformIO io
We know that whatever is going on in JwtIo is pure. The only side-effects it will perform are local (allocating memory). Those effects won't escape the code.
unsafePerformIO exists precisely to enable Haskell to call C
Problem: Type-level equivalent of Map
{-# LANGUAGE ExistentialQuantification #-}
data Payload pc = ClaimsSet { iss :: Iss
, sub :: Sub
, aud :: Aud
, exp :: Exp
, nbf :: Nbf
, iat :: Iat
, jti :: Jti
, privateClaims :: PrivateClaims pc
}
data Any = forall a . Any a
newtype PrivateClaims ts = PrivateClaims { unsafeClaimsMap :: HashMap String Any }
Let's start with this: PrivateClaims is parametrized by the precise type of what it contains. This is just an "untyped" Map - the premise is that we can recover from this type all information needed to safely access the map
Cheatsheet: Types, kinds and promotion
Let's imagine that type-system is (a very modest) programming language on its own. In this language, values are Haskell types and types are kinds. E.g:
> :kind! Int
Int :: *
> :kind! Either
Either :: * -> * -> *
> :kind Either Int
Either Int :: * -> *
Compare with:
> :type (5 :: Int)
(5 :: Int) :: Int
> :type Right
Right :: b -> Either a b
Cheatsheet: Types, kinds and promotion
Unfortunately, this language is similar to Python. Untyped. The kind system (as opposed to Haskell's rich type system) has too few kinds: *, *->* and so on.
The remedy is the DataKinds extension, which can extend Haskell's kind system with new kinds (just as the Haskell type system can be extended with new types). It works via datatype promotion - a data type becomes a new kind, its constructors become new types of this kind.
> data Pair a b = MkPair a b
> :kind! ['MkPair Int Int, 'MkPair Int String, 'MkPair String String]
['MkPair Int Int, 'MkPair Int String, 'MkPair String String] :: [Pair * *]
= '[ 'MkPair Int Int, 'MkPair Int String, 'MkPair String String]
> :kind! ['MkPair Int Int, String]
<interactive>:1:1: error:
• Expected kind ‘Pair * *’, but ‘String’ has kind ‘*’
• In the type ‘['MkPair Int Int, String]’
Cheatsheet: Types, kinds and promotion
GHC automatically promotes lists (we saw this in the previous example) but also strings - giving rise to type-level literals!
> :kind! "abc"
"abc" :: GHC.Types.Symbol = "abc"
> :kind! ['MkPair "abc" Int, 'MkPair "def" String]
['MkPair "abc" Int, 'MkPair "def" String] :: [Pair GHC.Types.Symbol *]
= '[ 'MkPair "abc" Int, 'MkPair "def" String]
How-to: Type-level equivalent of Map
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE TypeOperators #-}
data ClaimType (a :: Type) = Grant Symbol a
type name ->> a = 'Grant name a
newtype PrivateClaims (ts :: [ClaimType Type]) = PrivateClaims { unsafeClaimsMap :: HashMap String Any }
DataKinds to the rescue!
Information about claims can be encoded as a (kind) list of "pairs" - Symbol (type-level literal) to a regular type
> :kind! PrivateClaims '[ "name" ->> String, "userId" ->> Int ]
PrivateClaims '[ "name" ->> String, "userId" ->> Int ] :: *
= PrivateClaims
((':)
@(Claim *)
((->>) @{*} "name" String)
((':) @(Claim *) ((->>) @{*} "userId" Int) ('[] @(Claim *))))
Problem: Connecting values and types
First, a teaser: how can you create a value of type ("userId" ->> Int :: ClaimType Int) ?
.
.
.
You can't (because there is no value of ("userId" :: Symbol) )😭.
How-To: Connecting values and types
We need a way to talk about Claims at the term-level - to provide values to be stored in the map. One way to do it:
data ClaimName (name :: Symbol) = MkName
instance (name ~ name') => IsLabel name (ClaimName name') where -- this is for nicer syntax
fromLabel = MkName
newtype ClaimWitness (name :: Symbol) a = Witness a
(->>) :: ClaimName name -> a -> ClaimWitness name a
_ ->> a = Witness a
And now:
>:set -XOverloadedLabels
> :type #userId ->> (5 :: Int) #userId ->> (5 :: Int) :: ClaimWitness "userId" Int > :type (MkName @"userId") ->> (5 :: Int) (MkName @"userId") ->> (5 :: Int) :: ClaimWitness "userId" Int
How-To: Type-level equivalent of Map
> :t #userId ->> (5 :: Int) .: #name ->> "John Doe" .: nullClaims
#userId ->> (5 :: Int) .: #name ->> "John Doe" .: nullClaims
:: PrivateClaims
((':)
@(Claim *)
((->>) @{*} "userId" Int)
((':) @(Claim *) ((->>) @{*} "name" [Char]) Empty))
type Empty = ('[] :: [ClaimType Type])
nullClaims :: PrivateClaims Empty
nullClaims = PrivateClaims HashMap.empty
(.:) :: forall name a ts
. KnownSymbol name -- this is how GHC does value-type (typeclass equivalent of ClaimName)
=> ClaimWitness name a
-> PrivateClaims ts
-> PrivateClaims (name ->> a : ts)
(Witness a) .: (PrivateClaims store) = PrivateClaims
$ HashMap.insert claimName (Any a) store
where claimName = symbolVal (Proxy :: Proxy name)
How-To: Type-level equivalent of Map
type family UniqueName (name :: Symbol) (ts :: [ClaimType Type]) :: Bool where
UniqueName _ '[] = 'True
UniqueName n (n ->> _ : _) = 'False
UniqueName n (_ : rest) = UniqueName n rest
type family RestrictedName (name :: Symbol) :: Bool where
RestrictedName "iss" = 'True
RestrictedName "sub" = 'True
RestrictedName "aud" = 'True
RestrictedName "exp" = 'True
RestrictedName "nbf" = 'True
RestrictedName "iat" = 'True
RestrictedName "jti" = 'True
RestrictedName _ = 'False
> :kind! UniqueName "name" ["userId" ->> Int, "name" ->> String]
UniqueName "name" ["userId" ->> Int, "name" ->> String] :: Bool = 'False
> :kind! UniqueName "name" ["userId" ->> Int, "sth" ->> Int]
UniqueName "name" ["userId" ->> Int, "sth" ->> Int] :: Bool = 'True
> :kind! RestrictedName "name"
RestrictedName "name" :: Bool = 'False
Highlights: constraints and custom errors
type family RequireUniqueName (isUnique :: Bool) (name :: Symbol) :: Constraint where
RequireUniqueName 'True _ = ()
RequireUniqueName 'False n = TypeError ( 'Text "Claim "
':<>:
'ShowType n
':<>:
'Text " is not unique in this claim set" )
type family DisallowRestrictedName (isRestricted :: Bool) (name :: Symbol) :: Constraint where
DisallowRestrictedName 'False _ = ()
DisallowRestrictedName 'True n = TypeError
( 'ShowType n
':<>:
'Text " is the name of the registered claim (it is exposed as a field that must be set directly)")
type family CanAdd n ns :: Constraint where
CanAdd n ns = ( KnownSymbol n
, DisallowRestrictedName (RestrictedName n) n
, RequireUniqueName (UniqueName n ns) n )
How-To: Type-level equivalent of Map
> :type #userId ->> (5 :: Int) .: #userId ->> (6 :: Int) .: nullClaims <interactive>:1:1: error: • Claim "userId" is not unique in this claim set • In the expression: #userId ->> (5 :: Int) .: #userId ->> (6 :: Int) .: nullClaims > :t #sub ->> (6 :: Int) .: nullClaims <interactive>:1:1: error: • "sub" is the name of the registered claim (it is exposed as a field that must be set directly) • In the expression: #sub ->> (6 :: Int) .: nullClaims
(.:) :: forall name a ts
. CanAdd name ts
=> ClaimWitness name a
-> PrivateClaims ts
-> PrivateClaims (name ->> a : ts)
(Witness a) .: (PrivateClaims store) = PrivateClaims
$ HashMap.insert claimName (Any a) store
where claimName = symbolVal (Proxy :: Proxy name)
How-To: Type-level equivalent of Map
type family NameExists (name :: Symbol) (ts :: [ClaimType Type]) :: Bool where
NameExists _ '[] = 'False
NameExists n (n ->> _ : _) = 'True
NameExists n (_ : rest ) = NameExists n rest
type family RequireExists (exists :: Bool) (name :: Symbol) :: Constraint where
RequireExists 'True _ = ()
RequireExists 'False n = TypeError ('Text "Claim "
':<>:
'ShowType n
':<>: 'Text " does not exist in this claim set")
type family CanGet n ns :: Constraint where
CanGet n ns = (KnownSymbol n, RequireExists (NameExists n ns) n)
type family LookupClaimType (name :: Symbol) (ts :: [ClaimType Type]) :: Type where
LookupClaimType n (n ->> a : _) = a
LookupClaimType n (_ : rest) = LookupClaimType n rest
(.!) :: forall name ts
. CanGet name ts
=> PrivateClaims ts
-> ClaimName name
-> LookupClaimType name ts
pc .! name = unAny $ unsafeClaimsMap pc ! claimName
where
claimName = symbolVal (Proxy :: Proxy name)
unAny (Any a) = unsafeCoerce a
How-To: Type-level equivalent of Map
> :set -XOverloadedLabels
> pc = #userId ->> 5 .: #name ->> "John Doe" .: nullClaims
> pc .! #userId
5
> :type pc .! #userId
pc .! #userId :: Integer
> pc .! #name
"John Doe"
> :type pc .! #name
pc .! #name :: [Char]
> :type pc .! #woooooot
<interactive>:9:1: error:
• Claim "woooooot" does not exist in this claim set
• In the expression: pc .! #woooooot
How-To: Encoding more complex structures
class Encode c where
encode :: c -> JwtT -> EncodeResult
data Payload pc = ClaimsSet { iss :: Iss
, sub :: Sub
, aud :: Aud
, exp :: Exp
, nbf :: Nbf
, iat :: Iat
, jti :: Jti
, privateClaims :: PrivateClaims pc
}
instance Encode (PrivateClaims pc) => Encode (Payload pc) where
encode ClaimsSet { iss, sub, aud, exp, nbf, iat, jti, privateClaims } jwt =
encode iss jwt
>> encode sub jwt
>> encode aud jwt
>> encode exp jwt
>> encode nbf jwt
>> encode iat jwt
>> encode jti jwt
>> encode privateClaims jwt
Time to write instances
Cheatsheet: How to write instances?
instance Encode (PrivateClaims Empty) where
encode _ = nullEncode
Instances follow inductive reasoning.
The base case is empty set
Inductive step: encode a set of (n + 1) elements given encoding of set of n elements.
Notice how the given part becomes the context
instance
( ClaimEncoder a
, KnownSymbol name
, Encode (PrivateClaims tl)
)
=> Encode (PrivateClaims (name ->> a : tl)) where
encode pc jwt = encodeClaim claimName a jwt >> encode (getTail pc) jwt
where (claimName, a) = getHead pc
Cheatsheet: How to write instances?
getHead and getTail are simple eliminators.
Interestingly, getTail is a zero-cost function.
Also - RULES pragma kicks in - rewriter is smart enough to know that claim names are constant strings - zero overhead calling C
getHead
:: forall name a tl . KnownSymbol name => PrivateClaims (name ->> a : tl) -> (String, a)
getHead pc = (claimName, claimValue)
where
claimName = symbolVal (Proxy :: Proxy name)
claimValue = unAny $ unsafeClaimsMap pc ! claimName
unAny (Any a) = unsafeCoerce a
getTail :: PrivateClaims (name ->> a : tl) ns -> PrivateClaims tl ns
getTail = coerce
Problem: Better ergonomics
Working with type-level map might be more joyful if we eliminated the ceremony behind constructing values
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE OverloadedLabels #-}
pc1 = toPrivateClaims $ ( #name ->> ("John Doe" :: String)
, #userId ->> (12345 :: Int)
, #isAdmin ->> False
)
data ClaimObj = MkClaims { name :: String, userId :: Int, isAdmin :: Bool }
deriving stock Generic
instance ToPrivateClaims ClaimObj
pc2 = toPrivateClaims $ MkClaims { name = "John Doe"
, userId = 12345
, isAdmin = False
}
How-To: Better ergonomics
Create "smart" converters - as a type class. The key to doing it lies in retaining the correct type.
class ToPrivateClaims a where
type Claims a :: [ClaimType Type]
toPrivateClaims :: a -> PrivateClaims (Claims a)
instance ToPrivateClaims () where
type Claims () = Empty
toPrivateClaims _ = nullClaims
instance CanAdd n '[] => ToPrivateClaims (ClaimWitness n a) where
type Claims (ClaimWitness n a) = '[n ->> a]
toPrivateClaims a = a .: nullClaims
instance (CanAdd n2 '[], CanAdd n1 '[n2 ->> b]) => ToPrivateClaims (ClaimWitness n1 a, ClaimWitness n2 b) where
type Claims (ClaimWitness n1 a, ClaimWitness n2 b) = '[n1 ->> a, n2 ->> b]
toPrivateClaims (a, b) = a .: b .: nullClaims
--- and so on
Highlights: Better ergonomics with Generics
You can do the same for arbitrary records!
class RecordToPrivateClaims g where
type ClaimsFromRecord g :: [ClaimType Type]
genericToPrivateClaims :: g p -> PrivateClaims (ClaimsFromRecord g)
-- Step through metadata
instance RecordToPrivateClaims c => RecordToPrivateClaims (M1 i m c) where
type ClaimsFromRecord (M1 i m c) = ClaimsFromRecord c
genericToPrivateClaims (M1 c) = genericToPrivateClaims c
type family (+++) (lhs :: [k]) (rhs :: [k]) :: [k] where
'[] +++ rhs = rhs
(a : rest) +++ rhs = a : (rest +++ rhs)
-- Products: concatenate type lists AND concatenate maps
instance (RecordToPrivateClaims s1, RecordToPrivateClaims s2) => RecordToPrivateClaims (s1 :*: s2) where
type ClaimsFromRecord (s1 :*: s2) = ClaimsFromRecord s1 +++ ClaimsFromRecord s2
genericToPrivateClaims (s1 :*: s2) = PrivateClaims $ HashMap.union store1 store2
where
store1 = unsafeClaimsMap $ genericToPrivateClaims s1
store2 = unsafeClaimsMap $ genericToPrivateClaims s2
-- ... cont below
Highlights: Better ergonomics with Generics
You can do the same for arbitrary records!
-- .. continued
type family HasSelectorName (m :: Meta) :: Constraint where
HasSelectorName ('MetaSel ('Just s) _ _ _) = ()
HasSelectorName _ = TypeError
( 'Text "Only records with named fields can be converted to PrivateClaims. For instance, "
':$$:
'Text "data Good = MkGood { a :: Int, b :: String } is ok, but "
':$$:
'Text "data Bad = MkBad Int String is not"
)
type family SelectorName (m :: Meta) :: Symbol where
SelectorName ('MetaSel ('Just s) _ _ _) = s
-- Record fields
instance (Selector s, HasSelectorName s) => RecordToPrivateClaims (S1 s (Rec0 a)) where
type ClaimsFromRecord (S1 s (Rec0 a)) = '[SelectorName s ->> a]
genericToPrivateClaims (M1 (K1 a)) = PrivateClaims $ HashMap.singleton fieldName $ Any a
where
fieldName = selNameProxied (Proxy :: Proxy (S1 s (Rec0 a) p))
Highlights: Better ergonomics with Generics
Don't forget about nice error messages. it's good practice to handle the cases you don't know how to deal with via custom type errors
-- We don't handle sums (ie. choice between constructors)
instance
( TypeError
( 'Text "Only records with named fields can be converted to PrivateClaims. For instance, "
':$$:
'Text "data Good = MkGood { a :: Int, b :: String } is ok, but "
':$$:
'Text "data Bad = Bad1 Int | Bad2 String is not"
)
)
=> RecordToPrivateClaims (any :+: thing) where
genericToPrivateClaims = error "impossible"
Highlights: Better ergonomics with Generics
Without nice errors:
> :set -XDeriveGeneric
> data Bad = Bad1 Int | Bad2 String deriving Generic
> instance ToPrivateClaims Bad
<interactive>:4:10: error:
• No instance for (Libjwt.PrivateClaims.RecordToPrivateClaims
((:+:)
(C1
('MetaCons "Bad1" 'PrefixI 'False)
... + 15 more lines
How-To: Better ergonomics with Generics
With nice errors:
> :set -XDeriveGeneric
> data Bad = Bad1 Int | Bad2 String deriving Generic
> instance ToPrivateClaims Bad
<interactive>:4:10: error:
• Only records with named fields can be converted to PrivateClaims. For instance,
data Good = MkGood { a :: Int, b :: String } is ok, but
data Bad = Bad1 Int | Bad2 String is not
• In the expression: Libjwt.PrivateClaims.$dmtoPrivateClaims @(Bad)
In an equation for ‘toPrivateClaims’:
toPrivateClaims = Libjwt.PrivateClaims.$dmtoPrivateClaims @(Bad)
In the instance declaration for ‘ToPrivateClaims Bad’
Cheatsheet: Generics
Read the Haskell wiki article on Generics (it contains a complete working example). And then ...
> :set -XDeriveGeneric
> import GHC.Generics
> data ClaimsOrNot = MkClaims { a :: Int, b :: String } deriving Generic
> :kind! Rep (ClaimsOrNot)
Rep (ClaimsOrNot) :: * -> *
= D1
('MetaData "ClaimsOrNot" "Ghci1" "interactive" 'False)
(C1 ('MetaCons "MkClaims" 'PrefixI 'True)
((:*:)
(S1 ('MetaSel ('Just @ghc-prim-0.5.3:GHC.Types.Symbol "a") ...)
(Rec0 Int))
(S1 ('MetaSel ('Just @ghc-prim-0.5.3:GHC.Types.Symbol "b") ...)
(Rec0 String))))
Thank you!
Soon on Hackage!
GitHub: https://github.com/marcin-rzeznicki
Catch me on Reddit: https://www.reddit.com/user/rzeznik
I do NOT use Twitter or Facebook
I am looking for a Haskell job
Building a web library using super hard Haskell
By Marcin Rzeźnicki
Building a web library using super hard Haskell
- 1,220