Add login sessions

[blog.git] / Main.hs

diff --git a/Main.hs b/Main.hs
index 8a0c5a30e3c72642901247ca4f89ec630ff2bfa3..57edc52839e94f230b35cf47b610b99c08e0f7fc 100644 (file)
--- a/Main.hs
+++ b/Main.hs
@@ -1,15 +1,20 @@
 {-# LANGUAGE OverloadedStrings #-}
 module Main where
 
 {-# LANGUAGE OverloadedStrings #-}
 module Main where
 

-import Web.Scotty
+import Web.Scotty.Cookie
+import Web.Scotty.Trans

 import qualified Data.Text.Lazy as T
 import qualified Data.Text.Lazy.IO as T
 import Data.List
 import Data.Time
 import qualified Data.Text.Lazy as T
 import qualified Data.Text.Lazy.IO as T
 import Data.List
 import Data.Time

+import qualified Data.Map.Lazy as Map

 import Data.Maybe
 import Data.Ord
 import Data.Maybe
 import Data.Ord

-import Control.Monad.IO.Class
+import Data.IORef

 import Control.Monad
 import Control.Monad

+import Control.Monad.IO.Class
+import Control.Monad.Trans.Class
+import qualified Control.Monad.Trans.State as S

 import qualified Text.MMark as M
 import qualified Text.MMark.Extension.Common as M
 import Text.Casing
 import qualified Text.MMark as M
 import qualified Text.MMark.Extension.Common as M
 import Text.Casing


@@ -18,13 +23,56 @@ import Lucid
 import Lucid.Base
 import System.Directory
 import System.FilePath
 import Lucid.Base
 import System.Directory
 import System.FilePath

+import System.Random

 import Network.HTTP.Types
 
 import Network.HTTP.Types
 

+type Sessions = Map.Map T.Text T.Text
+type ActionM = ActionT T.Text (S.StateT Sessions IO)
+
+loggedIn :: ActionM Bool
+loggedIn = do
+  mCookie <- getCookie "session"
+  case mCookie of
+    Nothing -> return False
+    Just cookie -> Map.member (T.fromStrict cookie) <$> lift S.get
+
+currentUser :: ActionM (Maybe T.Text)
+currentUser = do
+  mCookie <- getCookie "session"
+  case mCookie of
+    Nothing -> return Nothing
+    Just cookie -> Map.lookup (T.fromStrict cookie) <$> lift S.get
+
+-- | Makes a function that carries over the state from one
+-- request to the next
+mkPreserve :: s -> IO ((S.StateT s IO) a -> IO a)
+mkPreserve s = do
+  ref <- newIORef s
+  return $ \f -> do
+    s <- readIORef ref
+    (x, s') <- S.runStateT f s
+    writeIORef ref s'
+    return x
+
+-- TODO: Use hashes
+logins :: Map.Map T.Text T.Text
+logins = Map.fromList
+           [ ("luke", "pass")
+           , ("dave", "abcd")
+           , ("antonia", "1234")
+           , ("owen", "haskell")
+           ]
+

 main :: IO ()
 main :: IO ()

-main = scotty 3000 $ do
+main = do
+  preserve <- mkPreserve mempty
+  scottyT 3000 preserve $ do

     get "/style.css" $ file "style.css"
 
     get "/style.css" $ file "style.css"
 

-  get "/create" $ html $ renderText $ html_ $ do
+    get "/create" $ do
+      authed <- loggedIn
+      if authed
+        then html $ renderText $ html_ $ do

           head_ $ do
             title_ "Create"
             style
           head_ $ do
             title_ "Create"
             style


@@ -36,21 +84,29 @@ main = scotty 3000 $ do
               with textarea_ [name_ "body", placeholder_ "# Your markdown here"] ""
               br_ []
               input_ [type_ "submit"]
               with textarea_ [name_ "body", placeholder_ "# Your markdown here"] ""
               br_ []
               input_ [type_ "submit"]

+        else status unauthorized401

 
     post "/create" $ do
       t <- param "title"
       b <- param "body"
 
     post "/create" $ do
       t <- param "title"
       b <- param "body"

-    p <- liftIO $ save b t
-    redirect ("posts/" <> title p)
+      p <- createPost b t
+      redirect (linkToPost p)

 
     post "/login" $ do
       username <- param "username"
       password <- param "password"
 
     post "/login" $ do
       username <- param "username"
       password <- param "password"

-    if username /= ("luke" :: T.Text) || password /= ("pass" :: T.Text)
+      if Map.lookup username logins /= Just password

         then status unauthorized401
         then status unauthorized401

-      else redirect "/create"
+        else do
+          session <- T.pack . show <$> liftIO (randomIO :: IO Int)
+          lift $ S.modify (Map.insert session username)
+          setSimpleCookie "session" (T.toStrict session)
+          redirect "/"
+
+    post "/logout" $ deleteCookie "session" >> redirect "/"

 
     get "/" $ do
 
     get "/" $ do

+      authed <- loggedIn

       posts <- liftIO $ do
         files <- listDirectory "posts"
         posts <- catMaybes <$> mapM load files
       posts <- liftIO $ do
         files <- listDirectory "posts"
         posts <- catMaybes <$> mapM load files


@@ -59,7 +115,13 @@ main = scotty 3000 $ do
         head_ $ style >> title_ "Cool Blog"
         body_ $ do
           p_ $ a_ [href_ "/"] "Cool Blog"
         head_ $ style >> title_ "Cool Blog"
         body_ $ do
           p_ $ a_ [href_ "/"] "Cool Blog"

-        with form_ [action_ "/login", method_ "post"] $ do
+          if authed
+            then do
+              a_ [href_ "/create"] "Create a Post"
+              br_ []
+              with form_ [action_ "/logout", method_ "post"] $
+                input_ [type_ "submit", value_ "Log Out"]
+            else with form_ [action_ "/login", method_ "post"] $ do

               input_ [name_ "username", placeholder_ "Username", type_ "text"]
               input_ [name_ "password", placeholder_ "Password", type_ "password"]
               input_ [type_ "submit"]
               input_ [name_ "username", placeholder_ "Username", type_ "text"]
               input_ [name_ "password", placeholder_ "Password", type_ "password"]
               input_ [type_ "submit"]


@@ -80,13 +142,13 @@ main = scotty 3000 $ do
                   p_ $ a_ [href_ "/"] "Home"
                   content
 
                   p_ $ a_ [href_ "/"] "Home"
                   content
 

-  where

 style = link_ [Attribute "rel" "stylesheet", Attribute "href" "/style.css"]
 
 data Post = Post
           { markdown :: T.Text
           , title    :: T.Text
           , date     :: UTCTime
 style = link_ [Attribute "rel" "stylesheet", Attribute "href" "/style.css"]
 
 data Post = Post
           { markdown :: T.Text
           , title    :: T.Text
           , date     :: UTCTime

+          , author   :: T.Text

           } deriving (Read, Show)
 
 load :: String -> IO (Maybe Post)
           } deriving (Read, Show)
 
 load :: String -> IO (Maybe Post)


@@ -96,17 +158,18 @@ load name = do
   readMaybe <$> readFile file
 
 render :: Post -> Maybe (Html ())
   readMaybe <$> readFile file
 
 render :: Post -> Maybe (Html ())

-render p@(Post markdown title date) =
+render p@(Post markdown title date author) =

   case M.parse (pathToPost p) (T.toStrict markdown) of
     Left e -> Nothing
     Right doc -> Just $
       with div_ [id_ (T.toStrict title)] $ do
         with a_ [href_ (T.toStrict $ linkToPost p)] $
           h1_ $ toHtml title
   case M.parse (pathToPost p) (T.toStrict markdown) of
     Left e -> Nothing
     Right doc -> Just $
       with div_ [id_ (T.toStrict title)] $ do
         with a_ [href_ (T.toStrict $ linkToPost p)] $
           h1_ $ toHtml title

-        i_ $ toHtml $ formatTime defaultTimeLocale "%a %e %B %Y" date
+        i_ $ toHtml $ "By " <> author <> ", " <> dateStr

         br_ []
         M.render (M.useExtensions extensions doc)
   where extensions = [M.ghcSyntaxHighlighter, M.skylighting, M.footnotes]
         br_ []
         M.render (M.useExtensions extensions doc)
   where extensions = [M.ghcSyntaxHighlighter, M.skylighting, M.footnotes]

+        dateStr = T.pack $ formatTime defaultTimeLocale "%a %e %B %Y" date

 
 linkToPost :: Post -> T.Text
 linkToPost p = T.pack $ "/posts" </> kebab (T.unpack (title p))
 
 linkToPost :: Post -> T.Text
 linkToPost p = T.pack $ "/posts" </> kebab (T.unpack (title p))


@@ -114,10 +177,14 @@ linkToPost p = T.pack $ "/posts" </> kebab (T.unpack (title p))
 pathToPost :: Post -> FilePath
 pathToPost p = "posts" </> kebab (T.unpack (title p))
 
 pathToPost :: Post -> FilePath
 pathToPost p = "posts" </> kebab (T.unpack (title p))
 

-save :: T.Text -> T.Text -> IO Post
-save md title = do
-  curTime <- getCurrentTime
-  let kTitle = T.pack $ kebab $ T.unpack title
-      p = Post md kTitle curTime
-  writeFile (pathToPost p) (show p)
+createPost :: T.Text -> T.Text -> ActionM Post
+createPost md title = do
+  author <- do
+    ma <- currentUser
+    case ma of
+      Just a -> return a
+      Nothing -> raise "Not logged in"
+  curTime <- liftIO getCurrentTime
+  let p = Post md title curTime author
+  liftIO $ writeFile (pathToPost p) (show p)

   return p
   return p