Client API

src/API.hs

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

src/Server.hs

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

src/Solidabis/API.hs

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