Building a web library using super hard Haskell

library
  import:              common-options
  hs-source-dirs:      src
  include-dirs:        src/cbits/jsmn
  c-sources:           src/cbits/HsJsonTokenizer.c
  extra-libraries:     jwt

{-# 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

{-# 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 
 }

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

-- | 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

signJwt it = MkEncoded $ unsafePerformJwtIO signTokenJwtIo
 where
  signTokenJwtIo = _ -- call C
    
{-# NOINLINE signJwt #-} -- prevent escaping

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

{-# 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 }