Implement alternative sign-in

.hlint.yaml

@@ -9,11 +9,13 @@
 # Warnings currently triggered by your code
 #- ignore: {name: "Use null"}
 - ignore: {name: "Redundant bracket"}
+- ignore: {name: "Redundant if"}
 #- ignore: {name: "Use isNothing"}
 #- ignore: {name: "Use list literal pattern"}
 - ignore: {name: "Use map once"}
 #- ignore: {name: "Use <$>"}
 #- ignore: {name: "Use mapMaybe"}
+- ignore: {name: "Use guards"}
 - ignore: {name: "Use newtype instead of data"}
 - ignore: {name: "Redundant $"} # TODO: add it back later
 #- ignore: {name: "Use fewer imports"}

assets/less/login.less

@@ -0,0 +1,112 @@
+@import "main.less";
+
+.login-main {
+    text-align: center;
+    font-family: "Helvetica", "Arial", "sans-serif";
+
+    h2 {
+        font-size: 1.3em;
+
+        span {
+            padding-right: 0.4em;
+        }
+    }
+
+    button {
+        padding: 0.4em 1.2em;
+    }
+
+    input.login-input-existing, input.login-input-register {
+        display: none;
+    }
+
+    label[for="login-input-existing"], label[for="login-input-register"] {
+        /* Position */
+        display: inline-block;
+        position: relative;
+        min-width: 10em;
+        margin-bottom: 1.5em;
+
+        /* Style */
+        padding: 15px 25px;
+        font-weight: 600;
+        text-align: center;
+        background-color: hsl(260, 0.05, 0.9);
+        color: #333;
+        border: 1px solid transparent;
+        cursor: pointer;
+    }
+
+    input.login-input-existing:checked ~ label[for="login-input-existing"], input.login-input-register:checked ~ label[for="login-input-register"] {
+        background-color: hsl(260, 0.05, 0.4);
+        color: #fff;
+    }
+
+    .login-existing, .login-register {
+        display: none;
+        font-family: "Varela Round";
+        font-size: 1.1em;
+
+        label {
+            margin-right: 1em;
+        }
+
+        h3 {
+            font-size: 1em;
+        }
+
+        input[type="radio"] {
+            margin-right: 0.5em;
+        }
+    }
+
+    .login-existing {
+        label {
+            margin-top: 1.5em;
+        }
+
+        .buttons {
+            margin-top: 0.5em;
+        }
+    }
+
+    .login-register {
+        text-align: left;
+        margin-left: auto;
+        margin-right: auto;
+        width: 35em;
+
+        .buttons {
+            margin-top: 0.5em;
+            text-align: center;
+        }
+
+        label {
+            margin-top: 0.5em;
+        }
+
+        p {
+            margin-top: 0.5em;
+            font-size: 0.83em;
+        }
+    }
+
+    .login-register-random, .login-register-custom {
+        display: none;
+    }
+
+    input.login-register-input-random:checked ~ .login-register-random, input.login-register-input-custom:checked ~ .login-register-custom {
+        display: block;
+    }
+
+    input.login-input-existing:checked ~ .login-existing, input.login-input-register:checked ~ .login-register {
+        display: block;
+    }
+
+    .login-register-random input {
+        width: 22em;
+        text-align: center;
+    }
+}
+
+/* TODO: mobile */

assets/typescript/login.ts

@@ -0,0 +1,23 @@
+import * as $ from "jquery";
+
+function areAllCharactersValidForHandle(handle : string) {
+    return handle.search(/[^A-Za-z0-9-_.]/) == -1;
+}
+
+$(document).ready(function() {
+    $("#new-handle-random").click(function() {
+        $(this).select();
+    });
+
+    $("input.handle").on("keypress", function(e) {
+        return areAllCharactersValidForHandle(e.key);
+    });
+
+    $(".login-main form").on("submit", function(e) {
+        let handle = $(this).children("input.handle").val();
+        if (!handle) {
+            alert("The handle must not be empty.");
+            return false;
+        }
+    });
+});

haskell/src/Server/Authentication/Handle.hs

@@ -0,0 +1,157 @@
+{-# 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 handle =
+    if T.null handle then
+        Left "the handle must not be empty"
+    else if (not $ T.all isValidCharacterForHandle handle) then
+        Left "the handle contains invalid characters"
+    else if T.length handle > 60 then
+        Left "the handle is too long"
+    else
+        Right ()
+    where
+        isValidCharacterForHandle :: Char -> Bool
+        isValidCharacterForHandle c = isAscii c && (isAlphaNum c || isValidSymbol c)
+        isValidSymbol :: Char -> Bool
+        isValidSymbol c = c `elem` ['-', '_', '.']
+
+bodyPolicy :: BodyPolicy
+bodyPolicy = defaultBodyPolicy "/tmp" 0 1000 1000
+
+handleRoot :: ServerConfiguration -> ServerResources -> ServerPart Response
+handleRoot serverConfiguration serverResources = msum
+    [ dir "login" $ handleLogin serverConfiguration serverResources
+    , dir "register" $ handleRegister serverConfiguration serverResources
+    ]
+
+handleLogin :: ServerConfiguration -> ServerResources -> ServerPart Response
+handleLogin serverConfiguration serverResources = do
+    -- Accept only POST requests
+    method POST
+    -- Read handle
+    decodeBody bodyPolicy
+    handle <- TL.toStrict <$> (body $ lookText "existing-handle")
+    -- Validate the handle
+    case validateHandle handle of
+        Left msg -> presentMessageAndRedirectToTargetUrl ("/login#existing" :: T.Text) $ "Invalid handle: " `T.append` (T.pack msg)
+        Right () -> do
+            -- Check if the handle exists
+            (liftIO $ runRedis serverConfiguration serverResources $ isHandleRegistered handle) >>= \case
+                Left _ -> internalServerError $ toResponse $ ("Failed to connect to the database." :: T.Text)
+                Right False -> presentMessageAndRedirectToTargetUrl ("/login#existing" :: T.Text) ("This handle does not exist. If you would like to use it, please register it first." :: T.Text)
+                Right True -> do
+                    -- If the sign-in attempt was successful, then register the cookie and return the user to the previous page
+                    addCookies $ (cookieDuration,) <$>
+                        [ mkCookie (T.unpack $ handleCookieName) $ T.unpack handle
+                        ]
+                    redirectToBodyRefererIfAllowed
+
+handleLogout :: ServerConfiguration -> ServerResources -> ServerPart ()
+handleLogout serverConfiguration serverResources = do
+    expireCookie (T.unpack $ handleCookieName)
+
+handleRegister :: ServerConfiguration -> ServerResources -> ServerPart Response
+handleRegister serverConfiguration serverResources = do
+    -- Accept only POST requests
+    method POST
+    -- Read handle
+    decodeBody bodyPolicy
+    handle <- TL.toStrict <$> (body $ lookText "new-handle")
+    -- Validate the handle
+    case validateHandle handle of
+        Left msg -> presentMessageAndRedirectToTargetUrl ("/login#register" :: T.Text) $ "Invalid handle: " `T.append` (T.pack msg)
+        Right () -> do
+            -- Attempt to register the handle
+            (liftIO $ runRedis serverConfiguration serverResources $ registerHandle handle) >>= \case
+                Left _ -> internalServerError $ toResponse $ ("Failed to connect to the database." :: T.Text)
+                Right False -> presentMessageAndRedirectToTargetUrl ("/login#register" :: T.Text) ("This handle is not available. Please try a different one." :: T.Text)
+                Right True -> do
+                    -- If the handle was successfully registered, then register the cookie and return the user to the previous page
+                    addCookies $ (cookieDuration,) <$>
+                        [ mkCookie (T.unpack $ handleCookieName) $ T.unpack handle
+                        ]
+                    redirectToBodyRefererIfAllowed
+
+readUserIdentityFromCookies :: ServerConfiguration -> ServerResources -> ServerPart (Maybe UserIdentity)
+readUserIdentityFromCookies serverConfiguration serverResources = do
+    handle <- T.pack <$> (lookCookieValue (T.unpack handleCookieName))
+    if T.null handle then
+        return Nothing
+    else if (isLeft $ validateHandle handle) then
+        return Nothing
+    else
+        (liftIO $ runRedis serverConfiguration serverResources $ isHandleRegistered handle) >>= \case
+            Left _ -> do
+                -- Failed to connect to the database
+                handleLogout serverConfiguration serverResources
+                return Nothing
+            Right False -> do
+                -- The handle did not exist in the database
+                handleLogout serverConfiguration serverResources
+                return Nothing
+            Right True -> do
+                let userIdentifier = UserIdentifier "handle" handle
+                let userPictureUrl = T.empty
+                let userGivenName = T.empty
+                let userFamilyName = T.empty
+                return . Just $ UserIdentity userIdentifier userPictureUrl userGivenName userFamilyName
+
+-- * Redis bindings
+registeredHandleKey :: T.Text -> T.Text
+registeredHandleKey handle = "RegisteredHandle" `T.append` handleKey where
+    normalizedHandle = T.toLower handle
+    handleKey = encodeRedisKey
+        [ ("handle", normalizedHandle)
+        ]
+
+isHandleRegistered :: T.Text -> Redis.Redis (Either Redis.Reply Bool)
+isHandleRegistered handle = do
+    let key = registeredHandleKey handle
+    let encodedKey = TE.encodeUtf8 key
+    Redis.exists encodedKey
+
+registerHandle :: T.Text -> Redis.Redis (Either Redis.Reply Bool)
+registerHandle handle = do
+    let key = registeredHandleKey handle
+    let encodedKey = TE.encodeUtf8 key
+    Redis.exists encodedKey >>= \case
+        Left reply ->
+            -- Something went wrong while communicating with Redis
+            return $ Left reply
+        Right True ->
+            -- If the handle already existed, then the request to register it was not successful
+            return $ Right False
+        Right False -> do
+            -- If the handle is available, then we register it and return success
+            _ <- Redis.set encodedKey (TE.encodeUtf8 T.empty)
+            return $ Right True
+
+-- * Cookies
+handleCookieName :: T.Text
+handleCookieName = "handle_id"
+
+cookieDuration :: CookieLife
+cookieDuration = (MaxAge $ 30 * 86400)

haskell/src/Server/Authentication/Main.hs

@@ -10,17 +10,20 @@ import Happstack.Server
 import Server.Core
 import qualified Server.Authentication.Google as Google
 import qualified Server.Authentication.OpenID as OpenID
+import qualified Server.Authentication.Handle as Handle
 import qualified Server.Authentication.Mock as Mock
 import Server.Authentication.Utils (redirectToCurrentRefererIfAllowed)
 
 handleRoot :: ServerConfiguration -> ServerResources -> ServerPart Response
 handleRoot serverConfiguration serverResources = msum
     [ dir "google" $ Google.handleRoot serverConfiguration serverResources
     , dir "openid" $ OpenID.handleRoot serverConfiguration serverResources
+    , dir "handle" $ Handle.handleRoot serverConfiguration serverResources
     , dir "mock" $ Mock.handleRoot serverConfiguration serverResources
     , dir "logout" $ do
         Google.handleLogout serverConfiguration serverResources
         OpenID.handleLogout serverConfiguration serverResources
+        Handle.handleLogout serverConfiguration serverResources
         Mock.handleLogout serverConfiguration serverResources
         redirectToCurrentRefererIfAllowed
     ]
@@ -29,5 +32,6 @@ readUserIdentityFromCookies :: ServerConfiguration -> ServerResources -> ServerP
 readUserIdentityFromCookies serverConfiguration serverResources = msum
     [ Google.readUserIdentityFromCookies serverConfiguration serverResources
     , OpenID.readUserIdentityFromCookies serverConfiguration serverResources
+    , Handle.readUserIdentityFromCookies serverConfiguration serverResources
     , Mock.readUserIdentityFromCookies serverConfiguration serverResources
     , return Nothing ]