diff --git a/youido/lib/Youido/Authentication.hs b/youido/lib/Youido/Authentication.hs index efe9abf..245368a 100644 --- a/youido/lib/Youido/Authentication.hs +++ b/youido/lib/Youido/Authentication.hs @@ -3,44 +3,36 @@ module Youido.Authentication where -import Web.Scotty -import Web.Scotty.Cookie -import Control.Concurrent.STM +import Control.Concurrent.STM +import Control.Monad.IO.Class import qualified Data.IntMap -import Control.Monad.IO.Class -import Data.Text (Text, unpack, pack) -import System.Random -import Text.Read (readMaybe) -import Data.ByteString(ByteString) +import System.Random +import Text.Read (readMaybe) +import Web.Cookie (Cookies, SetCookie(..), def) +import Data.ByteString.Char8 (pack, unpack) -------------------------------------------------------------------------- --- SERVING -------------------------------------------------------------------------- -newSession :: TVar (Data.IntMap.IntMap a) -> a -> ActionM () +newSession :: TVar (Data.IntMap.IntMap a) -> a -> IO SetCookie newSession tv x = do - n <- liftIO $ randomRIO (0,99999999999) - liftIO $ atomically $ modifyTVar' tv (Data.IntMap.insert n x) - setSimpleCookie "youisess" (pack $ show n) - return () - -lookupSession :: TVar (Data.IntMap.IntMap a) -> ActionM (Maybe (Int, a)) -lookupSession tv = do - mi <- (>>=readMaybe) . fmap unpack <$> getCookie "youisess" - case mi of - Nothing -> return Nothing - Just i -> do - mp <- liftIO $ readTVarIO tv - return $ fmap (i,) $ Data.IntMap.lookup i mp - - - -deleteSession :: TVar (Data.IntMap.IntMap a) -> Int -> ActionM () -deleteSession tv n = do - liftIO $ atomically $ modifyTVar' tv (Data.IntMap.delete n) - deleteCookie "youisess" - return () - + n <- randomRIO (0,99999999999) + atomically $ modifyTVar' tv (Data.IntMap.insert n x) + return $ def {setCookieName = "youisess", setCookieValue = (pack $ show n)} + +getSessionCookie :: Cookies -> Maybe Int +getSessionCookie cookies = (readMaybe . unpack) =<< lookup "youisess" cookies + +lookupSession :: TVar (Data.IntMap.IntMap a) -> Cookies -> IO (Maybe a) +lookupSession tv cookies = do + mp <- liftIO $ readTVarIO tv + return $ do + n <- getSessionCookie cookies + Data.IntMap.lookup n mp + +deleteSession :: TVar (Data.IntMap.IntMap a) -> Cookies -> IO () +deleteSession tv cookies = atomically . modifyTVar' tv $ maybe id Data.IntMap.delete (getSessionCookie cookies) diff --git a/youido/lib/Youido/Serve.hs b/youido/lib/Youido/Serve.hs index d51c356..e134132 100644 --- a/youido/lib/Youido/Serve.hs +++ b/youido/lib/Youido/Serve.hs @@ -3,73 +3,117 @@ module Youido.Serve where -import Youido.Types -import Youido.Authentication -import Web.Scotty -import Web.Scotty.Cookie -import Network.Wai.Middleware.RequestLogger (logStdout) - -import Lucid -import Lucid.Bootstrap -import Lucid.Bootstrap3 +import Youido.Types +import Youido.Authentication + +import Control.Concurrent.STM +import Lucid +import Lucid.Bootstrap +import Lucid.Bootstrap3 import qualified Lucid.Rdash as RD -import Control.Concurrent.STM -import qualified Data.IntMap -import Data.Text (Text, pack, unpack) -import Data.Monoid -import Control.Monad.State.Strict hiding (get) -import qualified Data.Map.Strict as Map -import Control.Monad.Reader +import Control.Monad.State.Strict hiding (get) + +import Network.HTTP.Types.URI (Query) +import Network.HTTP.Types.Method (parseMethod, StdMethod(..)) +import Network.HTTP.Types.Status (ok200, found302, methodNotAllowed405) +import Network.HTTP.Types.Header (Header, hContentType, hLocation, hCookie) +import Network.Wai (queryString, Application, pathInfo, responseLBS, requestHeaders, requestMethod, Request) +import qualified Network.Wai as Wai (Response) +import qualified Network.Wai.Handler.Warp as W +import Network.Wai.Middleware.RequestLogger (logStdout) +import Network.Wai.Parse (parseRequestBody, lbsBackEnd) +import Data.ByteString.Builder hiding (unpack) +import qualified Data.ByteString.Lazy as BL +import Web.Cookie (parseCookies, renderSetCookie) + +import qualified Data.IntMap +import Data.Text (Text) +import Data.Text.Encoding (decodeUtf8With, encodeUtf8) +import Data.Text.Encoding.Error (lenientDecode) +import qualified Data.Text.Lazy as TL +import qualified Data.Text.Lazy.Encoding as TLE +import Data.CaseInsensitive (mk) +import Data.Either (either) serveY :: Monad m => (forall a. auth -> m a -> IO a) -> YouidoT auth m () -> IO () serveY runM (YouidoT sm) = do let youidoDef = Youido [] "Not found!" (const id) (const $ const $const $return Nothing) 3000 y <- execStateT sm youidoDef - serve runM y + sessions <- newTVarIO Data.IntMap.empty + let application = logStdout $ app sessions runM y + W.run (_port y) application loginPage :: Maybe (Html ()) -> Html () loginPage mwarn = stdHtmlPage (return ()) $ container_ $ row_ $ div_ [class_ "col-sm-12 col-md-4 col-md-offset-4"] $ loginForm "/login" mwarn -serve :: Monad m => (forall a. auth -> m a -> IO a) -> Youido auth m -> IO () -serve runM y@(Youido _ _ _ looku port') = do - sessions <- newTVarIO (Data.IntMap.empty) - scotty port' $ do - middleware $ logStdout - get "/login" $ do - html $ renderText $ loginPage Nothing - get "/logout" $ do - msess <- lookupSession sessions - case msess of - Nothing -> return () - Just (i,_) -> deleteSession sessions i - html $ renderText $ loginPage $ Just $ div_ [class_ "alert alert-info"] "Goodbye!" - post "/login" $ do - femail <- param "inputEmail" - fpasswd <- param "inputPassword" - rq <- request - let incorrect = renderText $ loginPage $ Just $ - div_ [class_ "alert alert-danger"] "Incorrect user or password" - mu <- liftIO $ looku rq femail fpasswd +htmlContentType :: Header +htmlContentType = (hContentType, "text/html; charset=utf-8") + +mkParams :: Query -> [(TL.Text, TL.Text)] +mkParams = foldr go [] + where + go (_, Nothing) x = x + go (k, Just v) x = (TL.fromStrict $ decodeUtf8With lenientDecode k, + TL.fromStrict $ decodeUtf8With lenientDecode v) : x + +toWaiResponse :: Response -> Wai.Response +toWaiResponse (Response s hs c) = responseLBS s (f <$> hs) c + where + f :: (TL.Text, TL.Text) -> Header + f (k, v) = (mk (BL.toStrict $ TLE.encodeUtf8 k), BL.toStrict $ TLE.encodeUtf8 v) + +getParams :: Request -> IO [(TL.Text, TL.Text)] +getParams req = do + -- TODO: Use parseRequestBodyEx to restrict resource usage + (params, _) <- parseRequestBody lbsBackEnd req + return ((go <$> params) ++ queryParams) + where + go (k, v) = (TL.fromStrict $ decodeUtf8With lenientDecode k, + TL.fromStrict $ decodeUtf8With lenientDecode v) + queryParams = mkParams (queryString req) + +app :: Monad m => TVar (Data.IntMap.IntMap auth) -> (forall a. auth -> m a -> IO a) -> Youido auth m -> Application +app sessions runM y@(Youido _ _ _ looku _) req sendResp = do + let path = pathInfo req + method = either (const Nothing) Just $ parseMethod $ requestMethod req + query = queryString req + headers = requestHeaders req + cookies = maybe [] id $ (parseCookies <$> lookup hCookie headers) + + params <- getParams req + + case (method, path) of + (Nothing, _) -> sendResp (responseLBS methodNotAllowed405 [] "") + + (Just GET, ["login"]) -> sendResp $ (responseLBS ok200 []) $ renderBS $ loginPage Nothing + + (Just GET, ["logout"]) -> do + deleteSession sessions cookies + sendResp $ (responseLBS ok200 [htmlContentType]) $ renderBS $ loginPage $ Just $ div_ [class_ "alert alert-info"] "Goodbye!" + + (Just POST, ["login"]) -> do + let femail = maybe "" id (lookup "inputEmail" params) + fpasswd = maybe "" id (lookup "inputPassword" params) + incorrect = renderBS $ loginPage $ Just $ + div_ [class_ "alert alert-danger"] "Incorrect user or password" + + mu <- looku req (TL.toStrict femail) (encodeUtf8 $ TL.toStrict fpasswd) case mu of - Nothing -> html incorrect - Just u -> newSession sessions u >> redirect "/" - - matchAny (regex "/*") $ do - let go u = do - rq <- request - pars <- params - --liftIO $ print ("got request", rq) - Response stat hdrs conts <- liftIO $ runM u $ run y u (rq, pars) - status stat - mapM_ (uncurry setHeader) hdrs - raw conts - msess <- lookupSession sessions - case msess of - Nothing -> redirect "/login" - Just (i,u) -> go u + Nothing -> sendResp $ responseLBS ok200 [] incorrect + Just u -> do + setCookie <- BL.toStrict . toLazyByteString . renderSetCookie <$> newSession sessions u + sendResp (responseLBS found302 [(hLocation, "/"), ("Set-Cookie", setCookie)] "") + + _ -> do + s <- lookupSession sessions cookies + case s of + Nothing -> sendResp (responseLBS found302 [(hLocation, "/login")] "") + Just u -> do + resp <- runM u $ run y u (req, params) + sendResp (toWaiResponse resp) dashdoCustomJS :: Html () diff --git a/youido/lib/Youido/Types.hs b/youido/lib/Youido/Types.hs index 81a0389..9c745dd 100644 --- a/youido/lib/Youido/Types.hs +++ b/youido/lib/Youido/Types.hs @@ -10,7 +10,7 @@ module Youido.Types where -import Network.Wai hiding (Response) +import Network.Wai (Request, pathInfo, requestMethod) import qualified Data.Text as T import Data.Text (Text, pack, unpack) import Data.Text.Read(signed, decimal) @@ -34,7 +34,7 @@ import Data.Void import Lens.Micro.Platform hiding (to) import GHC.Generics import Lucid.PreEscaped -import Lucid.Bootstrap + import Control.Applicative((<|>)) import Text.Parsec (optionMaybe, getState, putState) @@ -47,13 +47,11 @@ import Text.Digestive.View (View(..)) import qualified Text.Digestive as D import qualified Text.Digestive.Form.List as D -import Control.Monad.Identity (Identity, runIdentity) - import Data.Maybe (maybeToList) import qualified Text.Digestive.Lucid.Html5 as DL -import Control.Monad.Trans.Class + -------------------------------------------------------------------------- --- PATHINFO diff --git a/youido/youido.cabal b/youido/youido.cabal index 321663d..d9970b6 100644 --- a/youido/youido.cabal +++ b/youido/youido.cabal @@ -37,7 +37,6 @@ library , microlens , mtl , random-fu - , scotty , postgresql-simple , wai-middleware-static , wai-extra @@ -51,13 +50,15 @@ library , stm , containers , random - , scotty-cookie , bcrypt , split , parsec , digestive-functors , digestive-functors-lucid , transformers + , warp + , cookie + , case-insensitive Executable youido-example main-is: examples/Example.hs