{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE ScopedTypeVariables #-}

module Server.Authentication.Handle
( handleRoot
, handleLogout
, readUserIdentityFromCookies
) where

import Server.Authentication.Utils (redirectToBodyRefererIfAllowed, presentMessageAndRedirectToTargetUrl)
import Server.Core
import Happstack.Server
import Server.Logic.Redis (runRedis, encodeRedisKey)
import Data.Char (isAscii, isAlphaNum)
import Data.Either (isLeft)
import Control.Monad (msum)
import Control.Monad.Trans (liftIO)
import qualified Database.Redis as Redis
import qualified Data.Text as T
import qualified Data.Text.Encoding as TE
import qualified Data.Text.Lazy as TL

validateHandle :: T.Text -> Either String ()
validateHandle :: Text -> Either String ()
validateHandle Text
handle =
    if Text -> Bool
T.null Text
handle then
        String -> Either String ()
forall a b. a -> Either a b
Left String
"the handle must not be empty"
    else if (Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> Text -> Bool
T.all Char -> Bool
isValidCharacterForHandle Text
handle) then
        String -> Either String ()
forall a b. a -> Either a b
Left String
"the handle contains invalid characters"
    else if Text -> Int
T.length Text
handle Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
60 then
        String -> Either String ()
forall a b. a -> Either a b
Left String
"the handle is too long"
    else
        () -> Either String ()
forall a b. b -> Either a b
Right ()
    where
        isValidCharacterForHandle :: Char -> Bool
        isValidCharacterForHandle :: Char -> Bool
isValidCharacterForHandle Char
c = Char -> Bool
isAscii Char
c Bool -> Bool -> Bool
&& (Char -> Bool
isAlphaNum Char
c Bool -> Bool -> Bool
|| Char -> Bool
isValidSymbol Char
c)
        isValidSymbol :: Char -> Bool
        isValidSymbol :: Char -> Bool
isValidSymbol Char
c = Char
c Char -> String -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Char
'-', Char
'_', Char
'.']

bodyPolicy :: BodyPolicy
bodyPolicy :: BodyPolicy
bodyPolicy = String -> Int64 -> Int64 -> Int64 -> BodyPolicy
defaultBodyPolicy String
"/tmp" Int64
0 Int64
1000 Int64
1000

handleRoot :: ServerConfiguration -> ServerResources -> ServerPart Response
handleRoot :: ServerConfiguration -> ServerResources -> ServerPart Response
handleRoot ServerConfiguration
serverConfiguration ServerResources
serverResources = [ServerPart Response] -> ServerPart Response
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, MonadPlus m) =>
t (m a) -> m a
msum
    [ String -> ServerPart Response -> ServerPart Response
forall (m :: * -> *) a.
(ServerMonad m, MonadPlus m) =>
String -> m a -> m a
dir String
"login" (ServerPart Response -> ServerPart Response)
-> ServerPart Response -> ServerPart Response
forall a b. (a -> b) -> a -> b
$ ServerConfiguration -> ServerResources -> ServerPart Response
handleLogin ServerConfiguration
serverConfiguration ServerResources
serverResources
    , String -> ServerPart Response -> ServerPart Response
forall (m :: * -> *) a.
(ServerMonad m, MonadPlus m) =>
String -> m a -> m a
dir String
"register" (ServerPart Response -> ServerPart Response)
-> ServerPart Response -> ServerPart Response
forall a b. (a -> b) -> a -> b
$ ServerConfiguration -> ServerResources -> ServerPart Response
handleRegister ServerConfiguration
serverConfiguration ServerResources
serverResources
    ]

handleLogin :: ServerConfiguration -> ServerResources -> ServerPart Response
handleLogin :: ServerConfiguration -> ServerResources -> ServerPart Response
handleLogin ServerConfiguration
serverConfiguration ServerResources
serverResources = do
    -- Accept only POST requests
    Method -> ServerPartT IO ()
forall (m :: * -> *) method.
(ServerMonad m, MonadPlus m, MatchMethod method) =>
method -> m ()
method Method
POST
    -- Read handle
    BodyPolicy -> ServerPartT IO ()
forall (m :: * -> *).
(ServerMonad m, MonadPlus m, MonadIO m, FilterMonad Response m,
 WebMonad Response m) =>
BodyPolicy -> m ()
decodeBody BodyPolicy
bodyPolicy
    Text
handle <- Text -> Text
TL.toStrict (Text -> Text) -> ServerPartT IO Text -> ServerPartT IO Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (ServerPartT IO Text -> ServerPartT IO Text
forall (m :: * -> *) a. HasRqData m => m a -> m a
body (ServerPartT IO Text -> ServerPartT IO Text)
-> ServerPartT IO Text -> ServerPartT IO Text
forall a b. (a -> b) -> a -> b
$ String -> ServerPartT IO Text
forall (m :: * -> *).
(Functor m, Monad m, HasRqData m) =>
String -> m Text
lookText String
"existing-handle")
    -- Validate the handle
    case Text -> Either String ()
validateHandle Text
handle of
        Left String
msg -> Text -> Text -> ServerPart Response
presentMessageAndRedirectToTargetUrl (Text
"/login#existing" :: T.Text) (Text -> ServerPart Response) -> Text -> ServerPart Response
forall a b. (a -> b) -> a -> b
$ Text
"Invalid handle: " Text -> Text -> Text
`T.append` (String -> Text
T.pack String
msg)
        Right () -> do
            -- Check if the handle exists
            (IO (Either Reply Bool) -> ServerPartT IO (Either Reply Bool)
forall a. IO a -> ServerPartT IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either Reply Bool) -> ServerPartT IO (Either Reply Bool))
-> IO (Either Reply Bool) -> ServerPartT IO (Either Reply Bool)
forall a b. (a -> b) -> a -> b
$ ServerConfiguration
-> ServerResources
-> Redis (Either Reply Bool)
-> IO (Either Reply Bool)
forall a. ServerConfiguration -> ServerResources -> Redis a -> IO a
runRedis ServerConfiguration
serverConfiguration ServerResources
serverResources (Redis (Either Reply Bool) -> IO (Either Reply Bool))
-> Redis (Either Reply Bool) -> IO (Either Reply Bool)
forall a b. (a -> b) -> a -> b
$ Text -> Redis (Either Reply Bool)
isHandleRegistered Text
handle) ServerPartT IO (Either Reply Bool)
-> (Either Reply Bool -> ServerPart Response)
-> ServerPart Response
forall a b.
ServerPartT IO a -> (a -> ServerPartT IO b) -> ServerPartT IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
                Left Reply
_ -> Response -> ServerPart Response
forall (m :: * -> *) a. FilterMonad Response m => a -> m a
internalServerError (Response -> ServerPart Response)
-> Response -> ServerPart Response
forall a b. (a -> b) -> a -> b
$ Text -> Response
forall a. ToMessage a => a -> Response
toResponse (Text -> Response) -> Text -> Response
forall a b. (a -> b) -> a -> b
$ (Text
"Failed to connect to the database." :: T.Text)
                Right Bool
False -> Text -> Text -> ServerPart Response
presentMessageAndRedirectToTargetUrl (Text
"/login#existing" :: T.Text) (Text
"This handle does not exist. If you would like to use it, please register it first." :: T.Text)
                Right Bool
True -> do
                    -- If the sign-in attempt was successful, then register the cookie and return the user to the previous page
                    [(CookieLife, Cookie)] -> ServerPartT IO ()
forall (m :: * -> *).
(MonadIO m, FilterMonad Response m) =>
[(CookieLife, Cookie)] -> m ()
addCookies ([(CookieLife, Cookie)] -> ServerPartT IO ())
-> [(CookieLife, Cookie)] -> ServerPartT IO ()
forall a b. (a -> b) -> a -> b
$ (CookieLife
cookieDuration,) (Cookie -> (CookieLife, Cookie))
-> [Cookie] -> [(CookieLife, Cookie)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
                        [ String -> String -> Cookie
mkCookie (Text -> String
T.unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ Text
handleCookieName) (String -> Cookie) -> String -> Cookie
forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack Text
handle
                        ]
                    ServerPart Response
redirectToBodyRefererIfAllowed

handleLogout :: ServerConfiguration -> ServerResources -> ServerPart ()
handleLogout :: ServerConfiguration -> ServerResources -> ServerPartT IO ()
handleLogout ServerConfiguration
serverConfiguration ServerResources
serverResources = do
    String -> ServerPartT IO ()
forall (m :: * -> *).
(MonadIO m, FilterMonad Response m) =>
String -> m ()
expireCookie (Text -> String
T.unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ Text
handleCookieName)

handleRegister :: ServerConfiguration -> ServerResources -> ServerPart Response
handleRegister :: ServerConfiguration -> ServerResources -> ServerPart Response
handleRegister ServerConfiguration
serverConfiguration ServerResources
serverResources = do
    -- Accept only POST requests
    Method -> ServerPartT IO ()
forall (m :: * -> *) method.
(ServerMonad m, MonadPlus m, MatchMethod method) =>
method -> m ()
method Method
POST
    -- Read handle
    BodyPolicy -> ServerPartT IO ()
forall (m :: * -> *).
(ServerMonad m, MonadPlus m, MonadIO m, FilterMonad Response m,
 WebMonad Response m) =>
BodyPolicy -> m ()
decodeBody BodyPolicy
bodyPolicy
    Text
handle <- Text -> Text
TL.toStrict (Text -> Text) -> ServerPartT IO Text -> ServerPartT IO Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (ServerPartT IO Text -> ServerPartT IO Text
forall (m :: * -> *) a. HasRqData m => m a -> m a
body (ServerPartT IO Text -> ServerPartT IO Text)
-> ServerPartT IO Text -> ServerPartT IO Text
forall a b. (a -> b) -> a -> b
$ String -> ServerPartT IO Text
forall (m :: * -> *).
(Functor m, Monad m, HasRqData m) =>
String -> m Text
lookText String
"new-handle")
    -- Validate the handle
    case Text -> Either String ()
validateHandle Text
handle of
        Left String
msg -> Text -> Text -> ServerPart Response
presentMessageAndRedirectToTargetUrl (Text
"/login#register" :: T.Text) (Text -> ServerPart Response) -> Text -> ServerPart Response
forall a b. (a -> b) -> a -> b
$ Text
"Invalid handle: " Text -> Text -> Text
`T.append` (String -> Text
T.pack String
msg)
        Right () -> do
            -- Attempt to register the handle
            (IO (Either Reply Bool) -> ServerPartT IO (Either Reply Bool)
forall a. IO a -> ServerPartT IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either Reply Bool) -> ServerPartT IO (Either Reply Bool))
-> IO (Either Reply Bool) -> ServerPartT IO (Either Reply Bool)
forall a b. (a -> b) -> a -> b
$ ServerConfiguration
-> ServerResources
-> Redis (Either Reply Bool)
-> IO (Either Reply Bool)
forall a. ServerConfiguration -> ServerResources -> Redis a -> IO a
runRedis ServerConfiguration
serverConfiguration ServerResources
serverResources (Redis (Either Reply Bool) -> IO (Either Reply Bool))
-> Redis (Either Reply Bool) -> IO (Either Reply Bool)
forall a b. (a -> b) -> a -> b
$ Text -> Redis (Either Reply Bool)
registerHandle Text
handle) ServerPartT IO (Either Reply Bool)
-> (Either Reply Bool -> ServerPart Response)
-> ServerPart Response
forall a b.
ServerPartT IO a -> (a -> ServerPartT IO b) -> ServerPartT IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
                Left Reply
_ -> Response -> ServerPart Response
forall (m :: * -> *) a. FilterMonad Response m => a -> m a
internalServerError (Response -> ServerPart Response)
-> Response -> ServerPart Response
forall a b. (a -> b) -> a -> b
$ Text -> Response
forall a. ToMessage a => a -> Response
toResponse (Text -> Response) -> Text -> Response
forall a b. (a -> b) -> a -> b
$ (Text
"Failed to connect to the database." :: T.Text)
                Right Bool
False -> Text -> Text -> ServerPart Response
presentMessageAndRedirectToTargetUrl (Text
"/login#register" :: T.Text) (Text
"This handle is not available. Please try a different one." :: T.Text)
                Right Bool
True -> do
                    -- If the handle was successfully registered, then register the cookie and return the user to the previous page
                    [(CookieLife, Cookie)] -> ServerPartT IO ()
forall (m :: * -> *).
(MonadIO m, FilterMonad Response m) =>
[(CookieLife, Cookie)] -> m ()
addCookies ([(CookieLife, Cookie)] -> ServerPartT IO ())
-> [(CookieLife, Cookie)] -> ServerPartT IO ()
forall a b. (a -> b) -> a -> b
$ (CookieLife
cookieDuration,) (Cookie -> (CookieLife, Cookie))
-> [Cookie] -> [(CookieLife, Cookie)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
                        [ String -> String -> Cookie
mkCookie (Text -> String
T.unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ Text
handleCookieName) (String -> Cookie) -> String -> Cookie
forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack Text
handle
                        ]
                    ServerPart Response
redirectToBodyRefererIfAllowed

readUserIdentityFromCookies :: ServerConfiguration -> ServerResources -> ServerPart (Maybe UserIdentity)
readUserIdentityFromCookies :: ServerConfiguration
-> ServerResources -> ServerPart (Maybe UserIdentity)
readUserIdentityFromCookies ServerConfiguration
serverConfiguration ServerResources
serverResources = do
    Text
handle <- String -> Text
T.pack (String -> Text) -> ServerPartT IO String -> ServerPartT IO Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (String -> ServerPartT IO String
forall (m :: * -> *).
(Functor m, Monad m, HasRqData m) =>
String -> m String
lookCookieValue (Text -> String
T.unpack Text
handleCookieName))
    if Text -> Bool
T.null Text
handle then
        Maybe UserIdentity -> ServerPart (Maybe UserIdentity)
forall a. a -> ServerPartT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe UserIdentity
forall a. Maybe a
Nothing
    else if (Either String () -> Bool
forall a b. Either a b -> Bool
isLeft (Either String () -> Bool) -> Either String () -> Bool
forall a b. (a -> b) -> a -> b
$ Text -> Either String ()
validateHandle Text
handle) then
        Maybe UserIdentity -> ServerPart (Maybe UserIdentity)
forall a. a -> ServerPartT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe UserIdentity
forall a. Maybe a
Nothing
    else
        (IO (Either Reply Bool) -> ServerPartT IO (Either Reply Bool)
forall a. IO a -> ServerPartT IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either Reply Bool) -> ServerPartT IO (Either Reply Bool))
-> IO (Either Reply Bool) -> ServerPartT IO (Either Reply Bool)
forall a b. (a -> b) -> a -> b
$ ServerConfiguration
-> ServerResources
-> Redis (Either Reply Bool)
-> IO (Either Reply Bool)
forall a. ServerConfiguration -> ServerResources -> Redis a -> IO a
runRedis ServerConfiguration
serverConfiguration ServerResources
serverResources (Redis (Either Reply Bool) -> IO (Either Reply Bool))
-> Redis (Either Reply Bool) -> IO (Either Reply Bool)
forall a b. (a -> b) -> a -> b
$ Text -> Redis (Either Reply Bool)
isHandleRegistered Text
handle) ServerPartT IO (Either Reply Bool)
-> (Either Reply Bool -> ServerPart (Maybe UserIdentity))
-> ServerPart (Maybe UserIdentity)
forall a b.
ServerPartT IO a -> (a -> ServerPartT IO b) -> ServerPartT IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
            Left Reply
_ -> do
                -- Failed to connect to the database
                ServerConfiguration -> ServerResources -> ServerPartT IO ()
handleLogout ServerConfiguration
serverConfiguration ServerResources
serverResources
                Maybe UserIdentity -> ServerPart (Maybe UserIdentity)
forall a. a -> ServerPartT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe UserIdentity
forall a. Maybe a
Nothing
            Right Bool
False -> do
                -- The handle did not exist in the database
                ServerConfiguration -> ServerResources -> ServerPartT IO ()
handleLogout ServerConfiguration
serverConfiguration ServerResources
serverResources
                Maybe UserIdentity -> ServerPart (Maybe UserIdentity)
forall a. a -> ServerPartT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe UserIdentity
forall a. Maybe a
Nothing
            Right Bool
True -> do
                let userIdentifier :: UserIdentifier
userIdentifier = Text -> Text -> UserIdentifier
UserIdentifier Text
"handle" Text
handle
                let userPictureUrl :: Text
userPictureUrl = Text
T.empty
                let userName :: Text
userName = Text
T.empty
                Maybe UserIdentity -> ServerPart (Maybe UserIdentity)
forall a. a -> ServerPartT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe UserIdentity -> ServerPart (Maybe UserIdentity))
-> (UserIdentity -> Maybe UserIdentity)
-> UserIdentity
-> ServerPart (Maybe UserIdentity)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UserIdentity -> Maybe UserIdentity
forall a. a -> Maybe a
Just (UserIdentity -> ServerPart (Maybe UserIdentity))
-> UserIdentity -> ServerPart (Maybe UserIdentity)
forall a b. (a -> b) -> a -> b
$ UserIdentifier -> Text -> Text -> UserIdentity
UserIdentity UserIdentifier
userIdentifier Text
userPictureUrl Text
userName

-- * Redis bindings
registeredHandleKey :: T.Text -> T.Text
registeredHandleKey :: Text -> Text
registeredHandleKey Text
handle = Text
"RegisteredHandle" Text -> Text -> Text
`T.append` Text
handleKey where
    normalizedHandle :: Text
normalizedHandle = Text -> Text
T.toLower Text
handle
    handleKey :: Text
handleKey = [(Text, Text)] -> Text
encodeRedisKey
        [ (Text
"handle", Text
normalizedHandle)
        ]

isHandleRegistered :: T.Text -> Redis.Redis (Either Redis.Reply Bool)
isHandleRegistered :: Text -> Redis (Either Reply Bool)
isHandleRegistered Text
handle = do
    let key :: Text
key = Text -> Text
registeredHandleKey Text
handle
    let encodedKey :: ByteString
encodedKey = Text -> ByteString
TE.encodeUtf8 Text
key
    ByteString -> Redis (Either Reply Bool)
forall (m :: * -> *) (f :: * -> *).
RedisCtx m f =>
ByteString -> m (f Bool)
Redis.exists ByteString
encodedKey

registerHandle :: T.Text -> Redis.Redis (Either Redis.Reply Bool)
registerHandle :: Text -> Redis (Either Reply Bool)
registerHandle Text
handle = do
    let key :: Text
key = Text -> Text
registeredHandleKey Text
handle
    let encodedKey :: ByteString
encodedKey = Text -> ByteString
TE.encodeUtf8 Text
key
    ByteString -> Redis (Either Reply Bool)
forall (m :: * -> *) (f :: * -> *).
RedisCtx m f =>
ByteString -> m (f Bool)
Redis.exists ByteString
encodedKey Redis (Either Reply Bool)
-> (Either Reply Bool -> Redis (Either Reply Bool))
-> Redis (Either Reply Bool)
forall a b. Redis a -> (a -> Redis b) -> Redis b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Left Reply
reply ->
            -- Something went wrong while communicating with Redis
            Either Reply Bool -> Redis (Either Reply Bool)
forall a. a -> Redis a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either Reply Bool -> Redis (Either Reply Bool))
-> Either Reply Bool -> Redis (Either Reply Bool)
forall a b. (a -> b) -> a -> b
$ Reply -> Either Reply Bool
forall a b. a -> Either a b
Left Reply
reply
        Right Bool
True ->
            -- If the handle already existed, then the request to register it was not successful
            Either Reply Bool -> Redis (Either Reply Bool)
forall a. a -> Redis a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either Reply Bool -> Redis (Either Reply Bool))
-> Either Reply Bool -> Redis (Either Reply Bool)
forall a b. (a -> b) -> a -> b
$ Bool -> Either Reply Bool
forall a b. b -> Either a b
Right Bool
False
        Right Bool
False -> do
            -- If the handle is available, then we register it and return success
            Either Reply Status
_ <- ByteString -> ByteString -> Redis (Either Reply Status)
forall (m :: * -> *) (f :: * -> *).
RedisCtx m f =>
ByteString -> ByteString -> m (f Status)
Redis.set ByteString
encodedKey (Text -> ByteString
TE.encodeUtf8 Text
T.empty)
            Either Reply Bool -> Redis (Either Reply Bool)
forall a. a -> Redis a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either Reply Bool -> Redis (Either Reply Bool))
-> Either Reply Bool -> Redis (Either Reply Bool)
forall a b. (a -> b) -> a -> b
$ Bool -> Either Reply Bool
forall a b. b -> Either a b
Right Bool
True

-- * Cookies
handleCookieName :: T.Text
handleCookieName :: Text
handleCookieName = Text
"handle_id"

cookieDuration :: CookieLife
cookieDuration :: CookieLife
cookieDuration = (Int -> CookieLife
MaxAge (Int -> CookieLife) -> Int -> CookieLife
forall a b. (a -> b) -> a -> b
$ Int
30 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
86400)