Typed & Authorized REST API with Servant: Part 2
Posted on March 22, 2016
TL;DR
In this second part, we add persistence, learn an interesting pattern for working with Kleisli arrows, and abstract away what it means to be a CRUD endpoint.
See the end product on github.
Disclaimer
I made this post for my own benefit, as a way of dumping my thoughts into text. As such, it is lacking a level of polish. (read: any level of polish ;) )
I hope to clean it up sometime when it’s design settles, and I am able to formulate it into prettier little value bombs.
11. Persistence with Persistent
Simplest addition to our app, using a connection pool:
import Database.Persist.Postgresql (runSqlPool
, ConnectionPool
, ConnectionString
, createPostgresqlPool
, withPostgresqlPool
, liftSqlPersistMPool
, Entity
, Single
, SqlBackend)
import Database.Persist.Sql (rawSql)
import Database.Persist.THselNow :: MonadIO m => ReaderT SqlBackend m [Single UTCTime]
selNow = rawSql "select now()" []
startApp = do
runStdoutLoggingT $ withPostgresqlPool connStr 10 $ liftSqlPersistMPool $ do
x <- selNow
liftIO (print x)
...12. Reader Monad, for read-only state
--------------------------------------------------
-- Reader API
type ReaderAPI = Get '[JSON] String
readerServerT :: ServerT ReaderAPI (Reader String)
readerServerT = ask
readerAPI :: Proxy ReaderAPI
readerAPI = Proxy
readerToHandler' :: forall a. Reader String a -> Handler a
readerToHandler' r = return (runReader r "yes!") -- <- configuration goes in here
readerToHandler :: Reader String :~> Handler
readerToHandler = Nat readerToHandler'
readerServer :: Server ReaderAPI
readerServer = enter readerToHandler readerServerT13. Reader Monad, for passing a pool of db connections into servant
type ReaderAPI = Get '[JSON] UTCTime
readerServerT :: ServerT ReaderAPI App -- (ReaderT (IO a) Config)
readerServerT = f
where
f :: App UTCTime
f = runDb selNow >>= return . unSingle . head
readerAPI :: Proxy ReaderAPI
readerAPI = Proxy
-- readerToHandler' :: Config -> forall a. Reader Config a -> Handler a
-- readerToHandler' cfg r = return (runReader r cfg)
readerToHandler :: Config -> App :~> ExceptT ServantErr IO
readerToHandler cfg = Nat (flip runReaderT cfg . runApp)
readerServer :: Config -> Server ReaderAPI
readerServer cfg = enter (readerToHandler cfg) readerServerT
--instance ToJSON Dbtime where
selNow :: MonadIO m => ReaderT SqlBackend m [Single UTCTime]
selNow = rawSql "select now()" []
-- belongs in Models.hs ?
runDb :: (MonadReader Config m, MonadIO m) => SqlPersistT IO b -> m b
runDb query = do
pool <- asks getPool
liftIO $ runSqlPool query poolstartApp :: IO ()
startApp = do
connPool <- runStdoutLoggingT $ createPostgresqlPool connStr 8
myKey <- generateKey
let env = Development
jwtCfg = defaultJWTSettings myKey
dbcfg = (Config connPool env)
cfg = defaultCookieSettings
:. jwtCfg
:. EmptyContext
api = Proxy :: Proxy (API '[JWT])
app :: Application
app = serveWithContext api
cfg
(server dbcfg defaultCookieSettings jwtCfg)14. Simplifying a chain of Either
You can see here, I each nesting point into Either Texts, with the hopes of composing things more nicely.
TL;DR is that using Kleisli Composition (>=>) I didn’t have to do that weird mangling, and was able to compose things anyways!
loginServerT :: JWTSettings -> ServerT LoginAPI App
loginServerT jwts = login :<|> new
where
login :: UnsafeLogin -> App String
login (UnsafeLogin email p) = do
-- turn string into key
case (keyFromValues [PersistText $ pack email]) of
Left _ -> throwError err500
Right k -> do
mu <- (runDb (get k)) :: (App (Maybe Login))
-- fetch user
case maybe (Left () ) Right mu of
Left _ -> throwError err405 -- couldn't find user
Right (Login _ hp) ->
-- validate password
case (if validatePassword (B.pack p) (B.pack hp)
then Right ()
else Left ()) of
Left _ -> throwError err401
Right _ -> (returnJwt jwts email)EitherT
login :: UnsafeLogin -> App String
login (UnsafeLogin email p) = eitherT (\_ -> throwError err401) return $ do
k <- hoistEither (keyFromValues [PersistText $ pack email])
(Login _ hp) <- (hoistEither . maybeToEither "couldn't find em") =<< (runDb (get k))
if validatePassword (B.pack p) (B.pack hp) then right () else left "wrong pass"
etoken <- liftIO (returnJwt jwts (User email Nothing Nothing))
bimapEitherT (pack . show) (B.unpack . BL.toStrict) (hoistEither etoken)No need for EitherT anymore, just use the monad more intelligently, including Apps MonadError
login :: UnsafeLogin -> App String
login (UnsafeLogin email p) = do
-- create a key
k <- return (keyFromValues [PersistText $ pack email])
k' <- either (const $ throwError err401) return k
-- fetch user
mu <- (runDb (get k'))
(Login _ hp) <- maybe (throwError err401) return mu
-- validate password
if validatePassword (B.pack p) (B.pack hp) then return () else throwError err401
-- create jwt token
etoken <- liftIO (returnJwt jwts (User email Nothing Nothing))
either (\_ -> throwError err401) (return . B.unpack . BL.toStrict) etokenAh ha! I need Kleisli Composition!
returnJwt :: (ToJWT a) => JWTSettings -> a -> IO (Either Error BL.ByteString)
returnJwt jwts obj = do
-- generate JWT
now <- getCurrentTime
let expiry = addUTCTime tokenDuration now
etoken <- makeJWT obj
jwts
(Just expiry)
return $ etoken
createKey :: (PersistEntity record) => String -> App (Key record)
createKey email = do
k <- return (keyFromValues [PersistText $ pack email])
k' <- either (const $ throwError err401) return k
return k'
fetchPass :: (Key Login) -> App String
fetchPass k = do
mu <- (runDb (get k))
(Login _ hp) <- maybe (throwError err401) return mu
return hp
validateHash :: String -> String -> App ()
validateHash p hp = if validatePassword (B.pack p) (B.pack hp) then return () else throwError err401
getToken :: (ToJWT a) => JWTSettings -> a -> App String
getToken jwts obj = do
etoken <- liftIO (returnJwt jwts obj)
either (\_ -> throwError err401) (return . B.unpack . BL.toStrict) etokenAnd compose it all together with a fish combinator >=>!
loginServerT :: JWTSettings -> ServerT LoginAPI App
loginServerT jwts = login :<|> new
where
login :: UnsafeLogin -> App String
login (UnsafeLogin email p) = createKey
>=> fetchPass
>=> (validateHash p)
>=> const (getToken jwts (User email Nothing Nothing))
$ email
15. Generalizing List, View, Create, Update, Delete:
Here is a snippet of code recommended in the haskell-servant docs:
-- TAKEN FROM: http://haskell-servant.readthedocs.io/en/stable/tutorial/Server.html
-- API for values of type 'a'
-- indexed by values of type 'i'
type APIFor a i =
Get '[JSON] [a] -- list 'a's
:<|> ReqBody '[JSON] a :> PostNoContent '[JSON] NoContent -- add an 'a'
:<|> Capture "id" i :>
( Get '[JSON] a -- view an 'a' given its "identifier" of type 'i'
:<|> ReqBody '[JSON] a :> PutNoContent '[JSON] NoContent -- update an 'a'
:<|> DeleteNoContent '[JSON] NoContent -- delete an 'a'
)
-- Build the appropriate 'Server'
-- given the handlers of the right type.
serverFor :: Handler [a] -- handler for listing of 'a's
-> (a -> Handler NoContent) -- handler for adding an 'a'
-> (i -> Handler a) -- handler for viewing an 'a' given its identifier of type 'i'
-> (i -> a -> Handler NoContent) -- updating an 'a' with given id
-> (i -> Handler NoContent) -- deleting an 'a' given its id
-> Server (APIFor a i)
serverFor = error "..."
-- implementation left as an exercise. contact us on IRC
-- or the mailing list if you get stuck!And the following is what I found worked well for my app:
type CRUD db act = ReqBody '[JSON] db :> Post '[JSON] (Key db)
:<|> Capture "id" (Key db) :> (
Get '[JSON] db
:<|> ReqBody '[JSON] act :> Put '[JSON] String -- Should prob be
-- NoContent, but
-- cljs-ajax thinks
-- those are errors
:<|> Delete '[JSON] String)Notice that my CRUD type needs parameters
db: the type that lives in the dbact: an “action” type that looks a bit more like an arbitrary hash map, representing updates that a user maybe wants to apply on a key
As you can imagine, there is a bit of boiler plate in maintaining the different requisite types for basically the same “object”, but by making my intent explicit in the different types, I maintain type-safety.
data TimeEntryAction = TimeEntryAction
{
actClockin :: Maybe CUTCTime
, actClockout :: Maybe CUTCTime
, actDescription :: Maybe String
} deriving (Show)
instance FromJSON TimeEntryAction where
parseJSON (Object o) = TimeEntryAction
<$> o .:? "clockin"
<*> o .:? "clockout"
<*> o .:? "description"
--actionToUpdates :: TimeEntryAction -> [P.Update TimeEntry]
actionToUpdates TimeEntryAction{..} = updateClockin
++ updateClockout
++ updateDescription
where
updateClockin = maybe [] (\x -> [TimeEntryClockin =. val x]) actClockin
updateClockout = maybe [] (\x -> [TimeEntryClockout =. val (Just x)]) actClockout
updateDescription = maybe [] (\x -> [TimeEntryDescription =. val x]) actDescription
--------------------------------------------------
-- Api
-- TODO: i can probably simplify the server implementation
type TimesAPI = Get '[JSON] [Entity TimeEntry] -- list times
:<|> CRUD TimeEntry TimeEntryAction -- CRUD timesAnd the matching server:
timesServerT :: AuthResult Token -> ServerT TimesAPI App
timesServerT (Authenticated tok) =
listTimes
:<|> (createTime
:<|> (\ti ->
getTime ti
:<|> updateTime ti
:<|> deleteTime ti
))
where listTimes :: App [Entity TimeEntry]
... ... ...Conclusion
In this post, we added persistence and a CRUD abstraction.
In the future, I want to include:
- adding user roles to authorization
- OAuth
- and refactoring into a Free or Operational Monad