Login.hs 2.95 KB
Newer Older
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22
{-# LANGUAGE FlexibleContexts #-}
module API.Controllers.Login (
  login,
  endSession
  -- logout
) where

import Control.Monad (void)
import Control.Monad.IO.Class
import Data.Text
import Data.Text.Encoding (encodeUtf8)
import Data.UUID (toASCIIBytes, UUID)
import Data.UUID.V4 (nextRandom)
import Database.Redis (runRedis)
import Web.Spock
import qualified Data.ByteString.Base64 as B64
import qualified Data.Text.Encoding as T
import qualified Database.Redis as R

import API.Controllers.Common
import API.Database.Common
import API.Errors
Allele Dev's avatar
Allele Dev committed
23
import API.Logging
24 25 26 27 28 29 30 31 32 33 34 35 36
import API.Models.Common
import qualified API.Database.User as DB

data SessionCheck
  = ValidSession
  | InvalidSession

data AuthCheck
  = AuthOkay Email Pass
  | AuthInvalid
  | AuthError
  | AuthMissing

Allele Dev's avatar
Allele Dev committed
37 38
login :: Pool -> R.Connection -> Log -> ActionT IO ()
login sqlC redisC logger = do
39 40 41 42 43 44 45 46
  auth <- header "Authorization"
  ret <- checkSession redisC
  case ret of
    ValidSession -> noContent
    InvalidSession -> do
      auth' <- liftIO $ checkAuth sqlC auth
      case auth' of
        AuthError -> errorResponse AuthenticationDown
Allele Dev's avatar
Allele Dev committed
47 48
        (AuthOkay (Email n) _) -> do
          skey <- liftIO $ makeSession redisC logger
49
          setSessionKey skey
Allele Dev's avatar
Allele Dev committed
50
          liftIO $ info logger Login Post $ n <> " has logged in"
51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82
          noContent
        AuthMissing -> errorResponse Unauthorized
        AuthInvalid -> errorResponse BadCredentials

checkAuth :: Pool -> Maybe Text -> IO AuthCheck
checkAuth sqlC (Just k) =
  case parseBasicAuth k of
    AuthOkay n p -> do
      ret <- DB.authenticate sqlC n p
      return $ case ret of
        Right DB.AuthSuccess -> AuthOkay n p
        Right DB.AuthFailed -> AuthInvalid
        Left _ -> AuthError
    e -> return e
checkAuth _ Nothing = return AuthMissing

checkSession :: R.Connection -> ActionT IO SessionCheck
checkSession redisC = do
  key <- getSessionKey
  case key of
    Nothing -> return InvalidSession
    (Just k) -> do
       ret <- liftIO $ runRedis redisC (R.exists (encodeUtf8 k))
       return $ case ret of
         (Right True) -> ValidSession
         _            -> InvalidSession

endSession :: R.Connection -> Text -> IO ()
endSession redisC key =
  let k = [encodeUtf8 key]
  in void (runRedis redisC (R.del k))

Allele Dev's avatar
Allele Dev committed
83 84
makeSession :: R.Connection -> Log -> IO UUID
makeSession redisC logger = do
85 86
  u <- nextRandom
  let key = toASCIIBytes u
Allele Dev's avatar
Allele Dev committed
87 88 89 90
  reply <- runRedis redisC (R.set key "" >> R.expire key 1200)
  case reply of
    (Left x) -> err logger Redis Post $ show x
    (Right _) -> return ()
91 92 93 94 95 96 97 98 99 100 101 102 103 104 105
  return u

parseBasicAuth :: Text -> AuthCheck
parseBasicAuth authH =
  case splitOn "Basic: " authH of
    ["", k] -> parseAuth k
    _ -> AuthInvalid
  where parseAuth k =
          let k' = B64.decode (T.encodeUtf8 k)
          in case fmap (splitOn ":" . T.decodeUtf8) k' of
            Left _ -> AuthInvalid
            Right ["",_] -> AuthInvalid
            Right [_,""] -> AuthInvalid
            Right [n,p] -> AuthOkay (Email n) (Pass p)
            Right _     -> AuthInvalid