nested-routes-5.0.0: examples/STM.hs

{-# LANGUAGE
    OverloadedStrings
  , ScopedTypeVariables
  , FlexibleContexts
  #-}


module Main where

import STM.Auth
import STM.Templates

import Network.Wai.Trans
import Network.Wai.Handler.Warp
import Network.Wai.Parse
import Network.HTTP.Types
import Web.Routes.Nested
import Data.Attoparsec.Text
import Text.Regex
import Data.Monoid
import qualified Data.Text.Lazy as LT
import qualified Data.ByteString as BS
import qualified Data.IntMap as IntMap
import Data.ByteArray (convert)
import Data.Function.Syntax

import Control.Concurrent.STM
import Control.Error.Util
import Control.Monad.Error.Class
import Control.Monad.IO.Class
import Control.Monad.Reader
import Control.Monad.Trans.Maybe
import Crypto.Random
import Crypto.Hash


data LoginError = InvalidLoginAttempt

defApp :: Application
defApp _ respond = respond $ textOnlyStatus status404 "404 :("

main :: IO ()
main = do
  cacheVar <- newTVarIO IntMap.empty
  uIdVar <- newTVarIO 0
  salt <- do (n :: BS.ByteString) <- liftIO $ getRandomBytes 256
             let n' = hash n :: Digest SHA512
                 n'' = convert n' :: BS.ByteString
             return n''
  let app a r1 r2 = runReaderT (routeActionAuth authenticate routes (liftIO .* a) r1 r2) $ AuthEnv cacheVar uIdVar salt
      routes = do
        handleAction o (Just rootHandle) Nothing
        handleAction fooRoute (Just fooHandle) $ Just $ do
          auth ShouldBeLoggedIn unauthHandle ProtectChildren
          handleAction barRoute    (Just barHandle)    Nothing
          handleAction doubleRoute (Just doubleHandle) Nothing
        handleAction emailRoute (Just emailHandle) Nothing
        handleAction bazRoute (Just bazHandle) Nothing
        handleAction loginRoute (Just loginHandle) Nothing
        handleAction logoutRoute (Just logoutHandle) $ Just $
          auth ShouldBeLoggedIn unauthHandle ProtectParent
        notFoundAction o (Just notFoundHandle) Nothing
  run 3000 $ app defApp
  where
    rootHandle = get $ text "Home"

    -- `/foo`
    fooRoute = l "foo" </> o
    fooHandle = get $ text "foo!"

    -- `/foo/bar`
    barRoute = l "bar" </> o
    barHandle = get $ do
      text "bar!"
      json ("json bar!" :: LT.Text)

    -- `/foo/1234e12`
    doubleRoute = p ("double", double) </> o
    doubleHandle d = get $ text $ LT.pack (show d) <> " foos"

    -- `/athan@foo.com`
    emailRoute = r ("email", mkRegex "(^[-a-zA-Z0-9_.]+@[-a-zA-Z0-9]+\\.[-a-zA-Z0-9.]+$)") </> o
    emailHandle e = get $ text $ LT.pack (show e) <> " email"

    -- `/baz`
    bazRoute = l "baz" </> o
    bazHandle = do
      get $ text "baz!"
      let uploader req = do liftIO $ print =<< strictRequestBody req
                            return undefined
          uploadHandle (Left Nothing) = text "Upload Failed"
          uploadHandle (Left (Just _)) = text "Should never happen"
          uploadHandle (Right _) = text "Woah! Upload content!"
          -- Hidden flaw ^ UserSession & LoginError are only options
      post uploader uploadHandle

    loginRoute = "login" </> o
    loginHandle = do
      get $ lucid loginPage
      postReq (login 128) loginResp
        where
          loginResp _ (Left Nothing) = textStatus status500 "Server malfunction :E"
          loginResp _ (Left (Just InvalidLoginAttempt)) = textStatusWith clearSessionResponse status403 "Bad login"
          loginResp _ (Right u) = textWith (mapResponseHeaders (++ makeSessionCookies u)) "logged-in"

    login s req =
      case requestBodyLength req of
        KnownLength b | b <= s -> do
          (ps,_) <- liftIO $ parseRequestBody (const $ const $ const $ return ()) req
          if firstIs (\(x,y) -> BS.null x || BS.null y) ps || length ps < 2
          then throwError $ Just InvalidLoginAttempt
          else do
            mSuccess <- runMaybeT $ do
              user <- hoistMaybe $ lookup "user" ps
              pass <- hoistMaybe $ lookup "password" ps
              liftIO $ putStrLn $ "<~!~> Attempted Login: " ++ show user ++ ", " ++ show pass ++ "\n"
              nUserSess <- newUserSession
              lift $ writeUserSession nUserSess
              return nUserSess
            note' (Just InvalidLoginAttempt) mSuccess
        _ -> throwError $ Just InvalidLoginAttempt
      where
        firstIs _ [] = True
        firstIs f (x:_) = f x


    logoutRoute = "logout" </> o
    logoutHandle = getReq $ \req -> do
      resp <- case getUserSession $ requestHeaders req of
        Nothing -> return "no session :s"
        Just userSession -> do
          lift $ deleteUserSession (userSessID userSession)
          return "logged-out"
      textWith clearSessionResponse resp

    unauthHandle SessionNotInCache   = get $ textStatusWith clearSessionResponse status401 "Unauthorized! - session not in cache"
    unauthHandle SessionTimedOut     = get $ textStatusWith clearSessionResponse status401 "Unauthorized! - session timed out"
    unauthHandle SessionMismatch     = get $ textStatusWith clearSessionResponse status401 "Unauthorized! - session mismatch"
    unauthHandle InvalidRequestNonce = get $ textStatusWith clearSessionResponse status401 "Unauthorized! - you're doing something sneaky!"
    unauthHandle NoSessionHeaders    = get $ textStatusWith clearSessionResponse status401 "Unauthorized! - are you sure you're logged in?"
    notFoundHandle = get $ textStatus status404 "Not Found :("