94 lines
2.9 KiB
Haskell
94 lines
2.9 KiB
Haskell
{-# LANGUAGE DataKinds #-}
|
|
{-# LANGUAGE DeriveGeneric #-}
|
|
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
|
{-# LANGUAGE OverloadedStrings #-}
|
|
{-# LANGUAGE TypeFamilies #-}
|
|
{-# LANGUAGE TypeOperators #-}
|
|
{-|
|
|
Module : Solidabis.API
|
|
Description : The client API for solidabis API
|
|
Copyright : (c) Mats Rauhala, 2019
|
|
License : BSD3
|
|
Maintainer : mats.rauhala@iki.fi
|
|
Stability : experimental
|
|
Portability : POSIX
|
|
|
|
Provides the client API for the solidabis API. Implemented through servant generics.
|
|
-}
|
|
module Solidabis.API
|
|
( getBullshits
|
|
, Bullshit(..)
|
|
, Message(..)
|
|
, HasClientEnv(..)
|
|
, HasToken(..)
|
|
, Token
|
|
)
|
|
where
|
|
|
|
import Control.Exception (throwIO)
|
|
import Control.Monad.Reader (MonadReader, asks)
|
|
import Control.Monad.Trans (MonadIO, liftIO)
|
|
import Data.Aeson
|
|
import Data.String (IsString)
|
|
import Data.Text (Text)
|
|
import Servant
|
|
import Servant.API.Generic
|
|
import Servant.Client
|
|
import Servant.Client.Core.Auth
|
|
import Servant.Client.Core.Request (Request)
|
|
import qualified Servant.Client.Core.Request as Req
|
|
import Servant.Client.Generic
|
|
|
|
-- | JSON representation of the message layer
|
|
newtype Message = Message { message :: Text }
|
|
deriving Generic
|
|
|
|
-- | JSON representation of the bullshit layer
|
|
newtype Bullshit
|
|
= Bullshit { bullshits :: [ Message ] }
|
|
deriving Generic
|
|
|
|
instance FromJSON Bullshit
|
|
instance FromJSON Message
|
|
|
|
newtype API route
|
|
= API { _bullshit :: route :- AuthProtect "jwt" :> "bullshit" :> Get '[JSON] Bullshit }
|
|
deriving (Generic)
|
|
|
|
-- | Has* style pattern for accessing the client environment
|
|
class HasClientEnv a where
|
|
getClientEnv :: a -> ClientEnv
|
|
setClientEnv :: a -> ClientEnv -> a
|
|
|
|
instance HasClientEnv ClientEnv where
|
|
getClientEnv = id
|
|
setClientEnv = const
|
|
|
|
routes :: (MonadReader r m, MonadIO m, HasClientEnv r) => API (AsClientT m)
|
|
routes = genericClientHoist
|
|
(\x -> asks getClientEnv >>= \env -> liftIO (runClientM x env >>= either throwIO return))
|
|
|
|
-- | Newtype wrapper over the jwt token
|
|
newtype Token = Token String
|
|
deriving (Semigroup, Monoid, ToHttpApiData, IsString, Show, FromJSON)
|
|
|
|
-- | Has* style pattern for accessing the authentication token
|
|
class HasToken a where
|
|
getToken :: a -> Token
|
|
setToken :: a -> Token -> a
|
|
|
|
instance HasToken Token where
|
|
getToken = id
|
|
setToken = const
|
|
|
|
type instance AuthClientData (AuthProtect "jwt") = Token
|
|
|
|
authReq :: Token -> Request -> Request
|
|
authReq token = Req.addHeader "Authorization" ("Bearer " <> token)
|
|
|
|
-- | Return the encoded sentences from the solidabis API
|
|
getBullshits
|
|
:: (HasToken r, MonadReader r m, MonadIO m, HasClientEnv r)
|
|
=> m Bullshit
|
|
getBullshits = asks getToken >>= \token -> _bullshit routes (mkAuthenticatedRequest token authReq)
|