Servant Basic Auth by using IO

servant_basic_auth.hs

{-
http://haskell-servant.readthedocs.io/en/stable/tutorial/Authentication.html

Servant tutorial exmplains how to do Basic Auth. But its checking userid and password is hard coded.
Usually we check them on database, which means we need IO. 
When I read the tutorial, I didn't figure out how to use IO. So I tried to rewrite the tutorial code.

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

module Authentication where

import Data.Aeson                       (ToJSON)
import Data.ByteString                  (ByteString, pack, unpack)
import Data.Text.Encoding               (decodeUtf8)
import Data.Map                         (Map, fromList)
import Data.Monoid                      ((<>))
import qualified Data.Map            as Map
import Data.Proxy                       (Proxy (Proxy))
import Data.Text                        (Text)
import GHC.Generics                     (Generic)
import Network.Wai                      (Request, requestHeaders)
import Network.Wai.Handler.Warp         (run)
import Servant.API                      ((:<|>) ((:<|>)), (:>), BasicAuth, Get, JSON)
import Servant.API.BasicAuth            (BasicAuthData (BasicAuthData))
import Servant.API.Experimental.Auth    (AuthProtect)
import Servant                          (throwError)
import Servant.Server                   (BasicAuthCheck (BasicAuthCheck),
                                         BasicAuthResult( Authorized , Unauthorized),
                                         Context ((:.), EmptyContext),
                                         err401, err403, errBody, Server,
                                         serveWithContext, Handler)
import Servant.Server.Experimental.Auth (AuthHandler, AuthServerData, mkAuthHandler)

-- | private data that needs protection
newtype PrivateData = PrivateData { ssshhh :: Text } deriving (Eq, Show, Generic)

instance ToJSON PrivateData

-- | public data that anyone can use.
newtype PublicData = PublicData { somedata :: Text } deriving (Eq, Show, Generic)

instance ToJSON PublicData

-- | A user we'll grab from the database when we authenticate someone
newtype User = User { userName :: Text } deriving (Eq, Show)

-- | a type to wrap our public api
type PublicAPI = Get '[JSON] [PublicData]

-- | a type to wrap our private api
type PrivateAPI = Get '[JSON] PrivateData

-- | our API
type BasicAPI = "public"  :> PublicAPI
           :<|> "private" :> BasicAuth "foo-realm" User :> PrivateAPI

-- | a value holding a proxy of our API type
basicAuthApi :: Proxy BasicAPI
basicAuthApi = Proxy

-- | 'BasicAuthCheck' holds the handler we'll use to verify a username and password.
{-

* Definition
newtype BasicAuthCheck usr = BasicAuthCheck { unBasicAuthCheck :: BasicAuthData -> IO (BasicAuthResult usr) }

* Type
BasicAuthCheck  :: (BasicAuthData -> IO (BasicAuthResult User)) -> BasicAuthCheck User
                                     ^^

-}
authCheck :: BasicAuthCheck User
authCheck = 
  --  check :: BasicAuthData -> IO (BasicAuthResult User)
  let check (BasicAuthData username password) = do
        -- ******** IO here *******
        print $ "userid=[" <> (decodeUtf8 username) <> "], password=[" <> (decodeUtf8 password) <> "]"
        -- ******** IO here *******
        return $ if username == "servant" && password == "server"
                 then (Authorized (User "servant"))
                 else Unauthorized
  in BasicAuthCheck check

-- | We need to supply our handlers with the right Context. In this case,
-- Basic Authentication requires a Context Entry with the 'BasicAuthCheck' value
-- tagged with "foo-tag" This context is then supplied to 'server' and threaded
-- to the BasicAuth HasServer handlers.
basicAuthServerContext :: Context (BasicAuthCheck User ': '[])
basicAuthServerContext = authCheck :. EmptyContext

-- | an implementation of our server. Here is where we pass all the handlers to our endpoints.
-- In particular, for the BasicAuth protected handler, we need to supply a function
-- that takes 'User' as an argument.
basicAuthServer :: Server BasicAPI
basicAuthServer =
  let publicAPIHandler                 = return [PublicData "foo", PublicData "bar"]
      privateAPIHandler (user :: User) = return (PrivateData (userName user))
  in publicAPIHandler :<|> privateAPIHandler

-- | hello, server!
basicAuthMain :: IO ()
basicAuthMain = run 8080 (serveWithContext basicAuthApi basicAuthServerContext basicAuthServer)