Token Authentication with Servant with IO

token-authentication-with-servant-with-IO.hs

{-
https://jerrington.me/posts/2016-06-18-token-authentication-with-servant.html
https://github.com/tsani/servant-otoke/blob/815c0aef69c3a0aac8b0f664a8122c8d2a490182/src/Main.hs

Add IO points

-}

{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}

module OToken where

import qualified Data.ByteString as BS
import qualified Data.Text       as T
import           Network.Wai              ( Application, requestHeaders )
import           Network.Wai.Handler.Warp ( run )
import           Servant
import           Servant.Server.Internal.RoutingApplication
import           Control.Monad.Base  -- for IO

data Otoke

instance HasServer sublayout context => HasServer (Otoke :> sublayout) context where

  type ServerT (Otoke :> sublayout) m = () -> ServerT sublayout m

  route Proxy context subserver =
    route (Proxy :: Proxy sublayout) context (addAuthCheck subserver go) where

      -- withRequest :: (Network.Wai.Internal.Request -> DelayedIO ()) -> DelayedIO ()
      -- go          :: DelayedIO ()
      go = withRequest $ \req -> do
        -- ***** IO *****
        -- liftBase :: IO () -> DelayedIO ()
        liftBase $ putStrLn "withRequest"
        -- ***** IO *****
        case parseHeaderMaybe =<< lookup "Authorization" (requestHeaders req) of
          Nothing -> delayedFail err401
          Just h -> do
             -- ***** IO *****
             -- liftBase :: IO () -> DelayedIO ()
             liftBase $ putStrLn $ "value=" ++ (T.unpack h)
             -- ***** IO *****
             if h `elem` pws then pure () else delayedFail err401

      pws :: [T.Text]
      pws = ("oToke " `T.append`) <$> [ "hello" , "world" ]

      parseHeaderMaybe :: FromHttpApiData a => BS.ByteString -> Maybe a
      parseHeaderMaybe = eitherMaybe . parseHeader where
        eitherMaybe :: Either e a -> Maybe a
        eitherMaybe e = case e of
          Left _ -> Nothing
          Right x -> Just x

type MyAPI = "unprotected" :>          Get '[PlainText] String 
        :<|> "protected"   :> Otoke :> Get '[PlainText] String

myServer :: Server MyAPI
myServer = pure "not secret" :<|> const (pure "secret")

app :: Application
app = serve (Proxy :: Proxy MyAPI) myServer

main :: IO ()
main = run 8081 app