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 :-)
- three libs on Hackage/Stackage: libjwt-typed, 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: No FFI
Cheatsheet: FFI
library
import: common-options
hs-source-dirs: src
include-dirs: src/cbits/jsmn
c-sources: src/cbits/HsJsonTokenizer.c
extra-libraries: jwt
Cheatsheet: FFI / bindings
{-# LANGUAGE ForeignFunctionInterface #-}
import Foreign
import Foreign.C.Types
import Foreign.C.String
-- | Wrapped pointer to /jwt_t/ with managed lifetime
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_grant_bool" c_jwt_add_grant_bool :: PJwtT -> CString -> CInt -> IO CInt
foreign import ccall unsafe "jwt.h jwt_add_grant_int" c_jwt_add_grant_int :: PJwtT -> CString -> CLong -> 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_grant_bool" c_jwt_get_grant_bool :: PJwtT -> CString -> IO CInt
foreign import ccall unsafe "jwt.h jwt_get_grant_int" c_jwt_get_grant_int :: PJwtT -> CString -> IO CLong
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_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_encode_str" c_jwt_encode_str :: PJwtT -> IO CString
foreign import ccall unsafe "jwt.h jwt_get_alg" c_jwt_get_alg :: PJwtT -> IO JwtAlgT
foreign import ccall unsafe "jwt.h jwt_get_header" c_jwt_get_header :: PJwtT -> CString -> 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 / glue
addHeader :: String -> ByteString -> JwtT -> JwtIO ()
addHeader h val (JwtT pjwt_t) =
JIO $ useAsCString val $ \p_val -> withForeignPtr pjwt_t $ \jwt ->
withCAString h $ \ph ->
throwIfNonZero_ "jwt_add_header" $ c_jwt_add_header jwt ph p_val
jwtEncode :: JwtT -> JwtIO ByteString
jwtEncode (JwtT pjwt_t) =
JIO
$ withForeignPtr pjwt_t
$ unsafePackMallocCString
<=< throwErrnoIfNull "jwt_encode_str"
. c_jwt_encode_str
jwtDecode :: ByteString -> ByteString -> JwtIO JwtT
jwtDecode key token = JIO
$ (if null key then ($ (nullPtr, 0)) else unsafeUseAsCStringLen key) doDecode
where
doDecode (p_key, key_len) = useAsCString token $ \p_token ->
mkJwtT_ "jwt_decode"
$ \ret -> c_jwt_decode ret p_token p_key $ fromIntegral key_len
mkJwtT_ :: String -> (Ptr PJwtT -> IO CInt) -> IO JwtT
mkJwtT_ loc ctr = alloca $ \ptr -> do
res <- ctr ptr
if res == 0 then wrapJwtPtr =<< peek ptr else throwLibjwt loc $ Errno res
Haskell - the world's finest imperative language
Cheatsheet: FFI / custom IO type
Even better - wrap it in a "custom" IO so that nobody calls putStrLn in the inappropriate places
-- | IO restricted to calling /libjwt/ and /jsmn/
newtype JwtIO a = JIO (IO a)
deriving newtype (Functor, Applicative, Monad, MonadThrow, MonadCatch)
unsafePerformJwtIO :: JwtIO a -> a
unsafePerformJwtIO (JIO io) = unsafePerformIO io
unsafePerformIO 🤔
Cheatsheet: unsafePerform(Jwt)IO
signJwt it = MkEncoded $ unsafePerformJwtIO signTokenJwtIo
where
signTokenJwtIo = _ -- call C
{-# NOINLINE signJwt #-} -- prevent escaping
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
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
Problem: No type-level programming
If you eliminate extensions enabling type-level programming (TypeFamilies, DataKinds, TypeApplications ...) , you (often) won't be able to:
- write the most correct solution (locked in the Worse Is Better),
- use your domain knowledge fully (introducing runtime burden)
Instead:
- encode solution in types,
- make sure ergonomics is first class.
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
((':)
((->>) "name" String)
((':) ((->>) "userId" Int) ('[] )))
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
((':)
((->>) "userId" Int)
((':) ((->>) "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
The final result
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE OverloadedLabels #-}
{-# LANGUAGE TypeOperators #-}
type MyPayload = '["user_name" ->> String, "is_root" ->> Bool, "user_id" ->> Int]
type MyJwt = Jwt MyPayload 'NoNs
mkPayload :: IO (Payload MyPayload 'NoNs)
mkPayload = jwtPayload
(withIssuer "myApp" <> withRecipient "https://myApp.com" <> setTtl 300)
( #user_name ->> "John Doe"
, #is_root ->> False
, #user_id ->> 12345
)
token :: IO ByteString
token = getToken . sign hmac512 <$> mkPayload
decodeAndValidate :: IO (ValidationNEL ValidationFailure (Validated MyJwt))
decodeAndValidate = jwtFromByteString settings mempty hmac512 =<< token
where settings = Settings { leeway = 5, appName = Just "https://myApp.com" }
The final result
Thank you!
On Hackage!
GitHub: https://github.com/marcin-rzeznicki/libjwt-typed
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
- 880