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

I'll use libjwt (hard stuff is coded for me - it uses GnuTLS/OpenSSL) and jansson (for some JSON).

Calling C from Haskell is easy and quite seamless!

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

Made with Slides.com

Building a web library using super hard Haskell

  • 1,135

More from Marcin Rzeźnicki