Accounts.hs

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

module Accounts where

-- , createUser, getUser, loginUser,
import Accounts.User (User(..), UserLogin(..), Accounts, users, createUser, getUser, initializeAccounts)
import Servant
import Servant.Auth.Server
import Control.Monad.IO.Class (liftIO)
import Anki
import Data.ByteString
import GHC.Generics (Generic)
import Data.Aeson
import Data.Aeson.TH
import Auth (Token(..), Tokens, issueToken)

type UserServer = Server UserApi
type AccountDB = Accounts


type UserApi = "login" :> ReqBody '[JSON] UserLogin
                       :> Post '[JSON] Token

-- type UserApi =  "users" :> Get '[JSON] [User]
--            :<|> "user"  :> ReqBody '[JSON] User :> Post '[JSON] User
--            :<|> "user"  :> Capture "id" Int :> Get '[JSON] (Maybe User)
           -- :<|> "login" :> ReqBody '[JSON] UserLogin :> Post '[JSON] (Maybe User)


userServer :: AccountDB -> Tokens -> UserServer
userServer accDB  tokenDB =  login accDB tokenDB
  where login a t u = verifyLogin a t u

verifyLogin :: Accounts -> Tokens -> UserLogin -> Handler Token
verifyLogin accDB tokenDB (UserLogin email password) =
  if (email == "test" && password == "test")
  then issueToken tokenDB email
  else return $ (Token "empty")

initializeAccountsDB :: IO AccountDB
initializeAccountsDB =  initializeAccounts

Anki.hs

{-# LANGUAGE DataKinds       #-}
{-# LANGUAGE TypeOperators   #-}

module Anki (AnkiDB, AnkiServer, initializeAnkiDB, ankiServer) where

import Data.Csv
import Servant
import Servant.Server                   (Handler, err401, err403, err404, errBody, Server)
import Control.Monad.IO.Class
import Anki.AnkiCard (CardID, AnkiCards, AnkiCard(..), ankiCards, createCard, getCard, updateCard, initializeAnkiCards)
import qualified Data.ByteString.Lazy as BL
import qualified Data.Vector as V
import Auth (Token)

type AnkiDB = AnkiCards
type AnkiServer = Server AnkiApi
type AnkiApi = "ankis" :> Get '[JSON] [AnkiCard]
         :<|>  "ankis" :> ReqBody '[JSON] AnkiCard :> Post '[JSON] AnkiCard
         :<|>  "anki"  :> Capture "cardId" CardID  :> Get '[JSON] (Maybe AnkiCard)
         :<|>  "anki"  :> Capture "cardId" CardID  :> ReqBody '[JSON] AnkiCard :> Put '[JSON] (Maybe AnkiCard)


ankiServer :: AnkiDB -> AnkiServer
ankiServer ankiDB =  ankiList
                :<|> newAnki
                :<|> anki
                :<|> updateAnki
  where ankiList                  = ankiCards ankiDB
        newAnki newCard           = createCard ankiDB newCard
        anki cardId               = getCard ankiDB cardId
        updateAnki cardId card    = updateCard ankiDB cardId card

initializeAnkiDB :: FilePath -> IO AnkiDB
initializeAnkiDB = initializeAnkiCards

Auth.hs

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

module Auth (Auth, Token(..), Tokens, authHandler, initializeTokens, authServerContext, issueToken) where

import Control.Monad.IO.Class         (liftIO)
import GHC.Generics (Generic)
import Data.Aeson
import Data.Aeson.TH
import qualified Control.Concurrent.STM    as T
import qualified Data.Map.Lazy             as Map
import qualified Data.ByteString.Char8     as C
import Data.Text                        (pack)
import Data.Text.Encoding               (decodeUtf8)
import Data.List                        (stripPrefix)
import Network.Wai                      (Request, requestHeaders)
import Servant                          (throwError)
import Servant.Server                   (Handler, ServantErr(..),Context ((:.), EmptyContext),
                                         err401, err403, err404, errBody, Server, ServantErr,)
import Servant.API.Experimental.Auth    (AuthProtect)
import Servant.Server.Experimental.Auth (AuthHandler, AuthServerData,
                                         mkAuthHandler)
import Accounts.User                     (UserLogin(..))
import Jose.Jwe (jwkEncode)
import Jose.Jwa
import Jose.Jwk (Jwk(..), generateRsaKeyPair, generateSymmetricKey, KeyUse(Enc), KeyId)
import Jose.Jwt (KeyId(..), Jwt(..), Payload(..))

type Auth = AuthProtect "jwt-auth"
type RsaPair = (Jwk, Jwk)
type TokenStore = Map.Map KeyId RsaPair
type Tokens = T.TMVar TokenStore
type JWT = (KeyId, RsaPair)


newtype Token   = Token { token :: String } deriving (Eq, Read, Show, Generic)

$(deriveJSON defaultOptions ''Token)
type instance AuthServerData (AuthProtect "jwt-auth") = Token

initializeTokens :: IO (Tokens)
initializeTokens = T.atomically $ T.newTMVar Map.empty

tokens :: Tokens -> Handler [JWT]
tokens tksThread = do
  tks <- liftIO $ (T.atomically . T.readTMVar) tksThread
  return $ Map.toList tks


createToken :: Tokens -> String -> Handler JWT
createToken tksThread usr = do
  tokens <- liftIO $ (T.atomically . T.takeTMVar) tksThread
  rsa   <- liftIO $ (generateRsaKeyPair 256 key Enc Nothing)
  let tokensToUpdate = Map.insert key rsa tokens
  updatedStorage <- liftIO $ (T.atomically . (T.putTMVar tksThread)) tokensToUpdate
  return $ (key, rsa)
  where key = (KeyId $ pack usr)

getToken :: Tokens -> String -> Handler (Maybe RsaPair)
getToken tksThread usr = do
  tks <- liftIO $ (T.atomically . T.readTMVar) tksThread
  return $ Map.lookup (KeyId $ pack usr) tks

issueToken :: Tokens -> String -> Handler Token
issueToken tks email = do
  (k, (kpub, kprv)) <- createToken tks email
  Right (Jwt jwt) <- liftIO $ jwkEncode RSA_OAEP A128GCM kpub (Claims "secret claims")
  return $ (Token $ C.unpack jwt)

authHandler :: AuthHandler Request UserLogin
authHandler =
 let handler req = case lookup "Authorization" (requestHeaders req) of
       Nothing -> throwError (err401 { errBody = "Missing auth header" })
       Just authKey ->
        case stripBearer $ C.unpack authKey of
          Nothing -> throwError (err401 { errBody = "Header Malformatted" })
          Just key -> if key == "YmRkNjVmYWQ5NDA4MmJjNzMyODU1ZTYx"  then  return $ (UserLogin "wdelhia" "loin") else throwError (err403 { errBody = "Invalid Token" })
 in mkAuthHandler handler
 where stripBearer = stripPrefix "Bearer "

authServerContext :: Context (AuthHandler Request UserLogin ': '[])
authServerContext = authHandler :. EmptyContext

Error.txt

    • Couldn't match type ‘ServerT
                             (Handler [Anki.AnkiCard.AnkiCard]) Handler’
                     with ‘Handler [Anki.AnkiCard.AnkiCard]’
      Expected type: Server API
        Actual type: (Token -> Protected)
                     :<|> (Unprotected :<|> Server Raw)
    • In the expression:
        protected dbs
        :<|> unprotected dbs :<|> serveDirectoryFileServer webRoot
      In an equation for ‘server’:
          server dbs
            = protected dbs
              :<|> unprotected dbs :<|> serveDirectoryFileServer webRoot

Libs.hs

{-# LANGUAGE DataKinds       #-}
{-# LANGUAGE TypeOperators   #-}

{-# LANGUAGE TypeFamilies          #-}
{-# LANGUAGE DeriveGeneric              #-}
{-# LANGUAGE FlexibleInstances          #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses      #-}
{-# LANGUAGE OverloadedStrings          #-}
{-# LANGUAGE ScopedTypeVariables        #-}
{-# LANGUAGE TemplateHaskell            #-}
{-# LANGUAGE FlexibleContexts           #-}

module Lib
    ( --    startApp
--    , app
    ) where


import Data.Aeson
import Data.Aeson.TH
import Data.Maybe (fromMaybe)
import qualified Data.Time as Time
import Network.Wai
import Network.Wai.Middleware.Cors
import Network.Wai.Handler.Warp
import           Network.Wai.Logger       (withStdoutLogger)
import Network.Wai.Middleware.RequestLogger (logStdoutDev)
import Servant
import Servant.API.Experimental.Auth    (AuthProtect)
import Accounts.User                     (UserLogin(..))
import Servant.Utils.StaticFiles
import System.Environment (lookupEnv)
import DB (DB(..), initializeDB, getDB)
import Auth (Auth, Token(..), initializeTokens, authServerContext)
import Accounts (UserServer, userServer)
import Accounts.User (UserLogin(..))
import Anki (AnkiServer, ankiServer)
import System.IO
import Data.List
import Data.List.Split
import Data.Map (Map)
import qualified Data.Map.Lazy as Map



type API =  Auth :> Protected
       :<|> Unprotected
       :<|> Raw


type Unprotected = UserServer
type Protected   = AnkiServer

webRoot :: FilePath
webRoot = "web/build/"

--
-- startApp :: IO ()
-- startApp = do
--     -- accounts <- putStrLn "Initializing Accounts..." >> initializeAccountsDB -- Set Memory DB for Accounts, later on will create a config file.
--     dbs      <- initializeDB
--     portEnv    <- lookupEnv "PORT"
--     let port = read (fromMaybe "8080" portEnv) :: Int
--     putStrLn "Server Running..." >> run  port (logStdoutDev $ app dbs )
--
-- --app :: DB -> CookieSettings -> JWTSettings -> Application
-- app dbs = appCors $ serveWithContext api authServerContext $ server dbs


-- need to allow cors communication with elm
appCors :: Middleware
appCors = cors $ const (Just corsResourcePolicy)

corsResourcePolicy :: CorsResourcePolicy
corsResourcePolicy =
    CorsResourcePolicy
        { corsOrigins = Nothing -- gives you /*
        , corsMethods = simpleMethods
        , corsRequestHeaders = simpleHeaders -- adds "Content-Type" to defaults
        , corsExposedHeaders = Nothing
        , corsMaxAge = Nothing
        , corsVaryOrigin = False
        , corsRequireOrigin = False
        , corsIgnoreFailures = False
        }


protected :: DB -> Token -> Protected
protected db (Token t) = ankiServer ankis
    where ankis = ankiDB db


unprotected :: DB -> Unprotected
unprotected db   = userServer accounts tokens
  where accounts = accountDB db
        tokens   = tokenDB db


api :: Proxy API
api = Proxy

--
server :: DB -> Server API
server dbs  = protected dbs
         :<|> unprotected dbs
         :<|> serveDirectoryFileServer webRoot


-- server :: DB -> Server API
-- server db = userServer accounts
--        :<|> ankiServer ankis
--        :<|> serveDirectoryFileServer webRoot
--     where accounts = accountDB db
--           ankis    = ankiDB db

parser :: IO ()
parser = do
     fHandler <- openFile "anki_list.csv" ReadWriteMode
    --  contents <- hGetContents fHandler :: IO String
    --  let contentList = splitByLine contents
    --  let mapC        = foldl mapById Map.empty contentList
    --  let updated     = replaceCard mapC "1" ["1","Protect","安全","あんぜん","\"For you protection, please fasten your seat belt\"","安全のためシートベルトを着用してください。","Noun"]
     hClose fHandler

splitByLine :: String -> [String]
splitByLine = splitOn "\n"

mapById :: Map String [String] -> String -> Map String [String]
mapById storage str = Map.insert cardId splitted storage
    where splitted  = splitOn "," str
          cardId    = head splitted

replaceCard :: Map String [String] -> String -> [String] -> Map String [String]
replaceCard storage cardId card = Map.insert cardId card storage
    where cardToUpdate = Map.lookup cardId storage