Main.hs

{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE OverloadedStrings #-}

module Main where
  
import Control.Monad.IO.Class (liftIO)
import Crypto.JOSE (Error)
import Crypto.JOSE.JWK (JWK)
import Data.Aeson (FromJSON, ToJSON, decode)
import Data.ByteString (ByteString)
import Data.Text.Lazy (Text)
import Data.Text.Lazy.Encoding (encodeUtf8)
import Data.Time.Clock (UTCTime)
import GHC.Generics
import Servant.Auth.Server

data Session = Session deriving (Generic, Show)
instance ToJSON Session
instance ToJWT Session
instance FromJSON Session
instance FromJWT Session

k :: Text
k = "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"

h :: Monad m
  => (Session -> JWTSettings -> Maybe UTCTime -> m (Either Error ByteString))
  -> Session
  -> JWTSettings
  -> Maybe UTCTime
  -> m (Either Error ByteString)
h func a b c = func a b c

main :: IO ()
main = do
  case decode . encodeUtf8 $ "{\"k\":\"" <> k <> "\",\"kty\":\"oct\"}" :: Maybe JWK of
    Nothing -> fail "nope"
    Just v  -> do
      let jwt = defaultJWTSettings v
      let g = liftIO . f -- what does one do here?
      r <- h g Session jwt Nothing
      print r
  where
    f :: Session -> JWTSettings -> Maybe UTCTime -> IO (Either Error ByteString)
    f _ _ _ = return . Right $ ""

{-
Proof.hs:40:24: error:
    • Couldn't match type ‘JWTSettings
                           -> Maybe UTCTime -> IO (Either Error ByteString)’
                     with ‘IO a’
      Expected type: Session -> IO a
        Actual type: Session
                     -> JWTSettings -> Maybe UTCTime -> IO (Either Error ByteString)
    • Probable cause: ‘f’ is applied to too few arguments
      In the second argument of ‘(.)’, namely ‘f’
      In the expression: liftIO . f
      In an equation for ‘g’: g = liftIO . f
    • Relevant bindings include
        g :: Session -> m a (bound at Proof.hs:40:11)
   |
40 |       let g = liftIO . f
   |
-}

Turns out the answer is to wrap 'f' with a concrete signature in MonadIO.