Client API

This commit is contained in:
Mats Rauhala 2019-10-15 21:01:57 +03:00
parent 046ae33fb4
commit 0b8ccb10e4
4 changed files with 72 additions and 0 deletions

View File

@ -22,11 +22,20 @@ executable koodihaaste
other-modules: Data.Language other-modules: Data.Language
, Data.NGram , Data.NGram
, Data.Caesar , Data.Caesar
, API
, Server
, Solidabis.API
-- other-extensions: -- other-extensions:
build-depends: base >=4.12 && <4.13 build-depends: base >=4.12 && <4.13
, servant , servant
, servant-server , servant-server
, servant-client
, servant-client-core
, text , text
, aeson
, http-client-tls
, mtl
, bytestring
, containers , containers
hs-source-dirs: src hs-source-dirs: src
default-language: Haskell2010 default-language: Haskell2010

1
src/API.hs Normal file
View File

@ -0,0 +1 @@
module API where

1
src/Server.hs Normal file
View File

@ -0,0 +1 @@
module Server where

61
src/Solidabis/API.hs Normal file
View File

@ -0,0 +1,61 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
module Solidabis.API 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
newtype Message = Message { message :: Text }
deriving Generic
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)
class HasClientEnv a where
getClientEnv :: a -> ClientEnv
setClientEnv :: a -> ClientEnv -> ClientEnv
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 Token = Token String
deriving (Semigroup, Monoid, ToHttpApiData, IsString)
type instance AuthClientData (AuthProtect "jwt") = Token
authReq :: Token -> Request -> Request
authReq token = Req.addHeader "Authorization" ("Bearer " <> token)
getBullshits
:: (MonadReader r m, MonadIO m, HasClientEnv r)
=> Token
-> m Bullshit
getBullshits token = _bullshit routes (mkAuthenticatedRequest token authReq)