diff --git a/koodihaaste.cabal b/koodihaaste.cabal index f96aa23..e4fd07e 100644 --- a/koodihaaste.cabal +++ b/koodihaaste.cabal @@ -22,11 +22,20 @@ executable koodihaaste other-modules: Data.Language , Data.NGram , Data.Caesar + , API + , Server + , Solidabis.API -- other-extensions: build-depends: base >=4.12 && <4.13 , servant , servant-server + , servant-client + , servant-client-core , text + , aeson + , http-client-tls + , mtl + , bytestring , containers hs-source-dirs: src default-language: Haskell2010 diff --git a/src/API.hs b/src/API.hs new file mode 100644 index 0000000..7d571a7 --- /dev/null +++ b/src/API.hs @@ -0,0 +1 @@ +module API where diff --git a/src/Server.hs b/src/Server.hs new file mode 100644 index 0000000..d78d913 --- /dev/null +++ b/src/Server.hs @@ -0,0 +1 @@ +module Server where diff --git a/src/Solidabis/API.hs b/src/Solidabis/API.hs new file mode 100644 index 0000000..312a951 --- /dev/null +++ b/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)