From 0b8ccb10e42e5b144e2955b16343e33b0ed48707 Mon Sep 17 00:00:00 2001
From: Mats Rauhala <mats.rauhala@iki.fi>
Date: Tue, 15 Oct 2019 21:01:57 +0300
Subject: [PATCH] Client API

---
 koodihaaste.cabal    |  9 +++++++
 src/API.hs           |  1 +
 src/Server.hs        |  1 +
 src/Solidabis/API.hs | 61 ++++++++++++++++++++++++++++++++++++++++++++
 4 files changed, 72 insertions(+)
 create mode 100644 src/API.hs
 create mode 100644 src/Server.hs
 create mode 100644 src/Solidabis/API.hs

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)