Example: servant based client API for GitHub Gists

Gists.hs

#!/usr/bin/env stack
-- stack --resolver lts-13.22 script

{-
   Run this as,
   > GITHUB_AUTH_TOKEN=<your_gists_token> ./Gists.hs
-}

{-# LANGUAGE DataKinds           #-}
{-# LANGUAGE DeriveGeneric       #-}
{-# LANGUAGE OverloadedStrings   #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell     #-}
{-# LANGUAGE TypeFamilies        #-}
{-# LANGUAGE TypeOperators       #-}

module Main where

import           Data.Aeson.Casing       (aesonDrop, snakeCase)
import           Data.Aeson.TH           (deriveJSON)
import           Data.Proxy
import           Data.Text
import           Data.Time.Clock
import           Network.HTTP.Client.TLS (newTlsManager)
import           Servant.API             hiding (addHeader)
import           Servant.Client
import           Servant.Client.Core     (AuthClientData, AuthenticatedRequest,
                                          Request, addHeader,
                                          mkAuthenticatedRequest)
import           UnliftIO.Environment    (lookupEnv)
import           UnliftIO.Exception      (throwString)


-- | The datatype we'll use to authenticate a request. If we were wrapping
-- something like OAuth, this might be a Bearer token.
type instance AuthClientData (AuthProtect "token") = String

-- | A method to authenticate a request
authenticateReq :: String -> Request -> Request
authenticateReq s req = addHeader "token" s req

-- | Data type to capture github gists response
-- N B This is only illustrative and is incomplete
newtype GistsResp = GistsResp { grUrl :: Text }
                  deriving (Eq, Show)

$(deriveJSON (aesonDrop 2 snakeCase) ''GistsResp)


-- | The API for accessing GitHub Gists
type GistsAPI = "gists" :> "public" :> QueryParam "since" UTCTime :> Header "User-Agent" Text :> Get '[JSON] [GistsResp]
                 :<|>
                 "users" :> Capture "username" Text :> "gists" :> AuthProtect "token" :> Header "User-Agent" Text :> Get '[JSON] [GistsResp]


-- | Boilerplate to keep our beloved GHC type-system informed of our
-- type-level magic
gistsAPI :: Proxy GistsAPI
gistsAPI = Proxy

-- | Generated client SDK functions for the corresponding APIs defined
-- in the type above
listPublicGists :: Maybe UTCTime -> Maybe Text -> ClientM [GistsResp]
listUserGists :: Text
              -> AuthenticatedRequest (AuthProtect "token")
              -> Maybe Text
              -> ClientM [GistsResp]

-- | User Agent string to be used with all client API calls
clientHdr :: Maybe Text
clientHdr = Just "servant-client-test"

(listPublicGists :<|> listUserGists) = client gistsAPI

-- | Sample function to demonstrate how to use the generated client
-- APIs
queries :: ClientM [GistsResp]
queries = do
    ghAuthTokenMay <- lookupEnv "GITHUB_AUTH_TOKEN"
    ghAuthToken <- maybe (throwString "missing auth token") return ghAuthTokenMay
    listUserGists "your-user" (mkAuthenticatedRequest ghAuthToken authenticateReq)
      clientHdr


main :: IO ()
main =  do
  manager' <- newTlsManager
  let url = BaseUrl Https "api.github.com" 443 ""

  res <- runClientM queries (mkClientEnv manager' url)
  case res of
    Left err    -> putStrLn $ "Error: " ++ show err
    Right gists -> print gists