Example.hs

{-# LANGUAGE DataKinds                  #-}
{-# LANGUAGE DeriveGeneric              #-}
{-# LANGUAGE MultiParamTypeClasses      #-}
{-# LANGUAGE OverloadedStrings          #-}
{-# LANGUAGE TypeFamilies               #-}
{-# LANGUAGE TypeOperators              #-}
{-# LANGUAGE RecordWildCards            #-}

import AuthAPI
import Data.Default
import Data.IORef (newIORef, readIORef)
import Network.Wai (Application)
import Network.Wai.Handler.Warp (run)
import Servant (Proxy(..), Server, (:>), (:<|>)(..), Raw, Get, Capture)
import Servant.API.ContentTypes (JSON)
import Servant.HTML.Blaze
import Servant.Server (Context ((:.), EmptyContext), serveWithContext)
import Servant.Server.Experimental.Auth.HMAC
import Servant.Utils.StaticFiles (serveDirectory)
import System.Posix.Directory (getWorkingDirectory)
import Text.Blaze.Html5 ((!))
import Text.Blaze.Html5 (Markup)
import qualified Data.Map as Map
import qualified Text.Blaze.Html5 as H
import qualified Text.Blaze.Html5.Attributes as A


type ExampleAPI = Get '[HTML] Markup
             :<|> "static" :> Raw
             :<|> "api" :> "templates" :> Get '[JSON] [String]
             :<|> "api" :> "templates" :> Capture "name" String :> Get '[HTML] Markup
             :<|> "api" :> AuthAPI


server :: FilePath -> Storage -> Server ExampleAPI
server root storage = serveIndex
                 :<|> serveStatic
                 :<|> serveTemplates
                 :<|> serveTemplate
                 :<|> serveAuth storage where

  serveIndex = return indexPage
  serveStatic = serveDirectory root
  serveTemplates = return $ map fst templates
  serveTemplate name = return $ (maybe defaultPage id) (lookup name templates)

  templates = [
      ("home"   , homePage)
    , ("login"  , loginPage)
    , ("private", privatePage)
    ]


app :: FilePath -> Storage -> AuthTokenProvider -> AuthHmacSettings -> Application
app root storage tokenProvider settings = serveWithContext
  (Proxy :: Proxy ExampleAPI)
  ((defaultAuthHandler tokenProvider settings) :. EmptyContext)
  (server root storage)

main :: IO ()
main = do
  root <- (++ "/example/client/result/static") <$> getWorkingDirectory
  storage <- newIORef $ Map.empty
  let tokenProvider username = (Map.lookup username) <$> (readIORef storage)
  run 8080 (app root storage tokenProvider (def::AuthHmacSettings))


indexPage :: H.Html
indexPage = H.docTypeHtml $ do
  H.head $ do
    H.script ! A.src "static/app.js" ! A.type_ "application/javascript;version=1.8" $ ""
  H.body $ do
    H.div ! A.class_ "app" $ "Loading..."

homePage :: H.Html
homePage = do
  H.p "This is an example of using servant-auth-hmac library."
  H.p "Use login page to get access to the private page."

loginPage :: H.Html
loginPage = do
  H.form ! A.method "post" ! A.action "/api/login" $ do
    H.table $ do
      H.tr $ do
       H.td $ "username:"
       H.td $ H.input ! A.type_ "text" ! A.name "username"
      H.tr $ do
       H.td $ "password:"
       H.td $ H.input ! A.type_ "password" ! A.name "password"
    H.input ! A.type_ "submit"
  H.p ! A.class_ "feedback" $ ""

privatePage :: H.Html
privatePage = do
  H.p $ H.b "username: " >> "{{username}}"
  H.p $ H.b "token: "    >> "{{token}}"
  H.p $ H.b "secret: "   >> "{{secret}}"

defaultPage :: H.Html
defaultPage = H.p "not found"