my attempt at a pastebin clone

miguelpastebin.hs

{-# LANGUAGE OverloadedStrings, DeriveDataTypeable, TypeFamilies, TemplateHaskell #-}
module Main (main) where

import Web.Scotty
--import qualified Network.Wai.Parse as P
import qualified Data.ByteString.Char8 as B8
import Lucid
import Lucid.Base
import Web.Scotty.Session
import Network.HTTP.Types.Status

import Crypto.Hash

--import qualified Data.ByteString.Lazy.Char8 as BL8
import qualified Data.Text as T
import qualified Data.Text.Lazy as TL
import qualified Data.Map as M
import Data.Maybe
import Data.Monoid (mconcat)
import Data.Typeable
import Data.SafeCopy
import Data.Acid

--import Control.Monad (when)
import Control.Monad.IO.Class (liftIO)
import Control.Lens
import Control.Monad.Reader.Class (ask)
import qualified Control.Monad.State.Class as ST (modify, put)


hexSha256 :: T.Text -> T.Text
hexSha256 txt = T.pack $ take 8 $ show (hash (B8.pack $ T.unpack txt) :: Digest SHA256)

type Username = T.Text
type PasteHash = T.Text

data UserData = UserData { _userPassword :: T.Text, _userPastes:: [T.Text] } deriving (Show, Typeable) --array of hashes 
makeLenses ''UserData

type PasteName = T.Text
type PasteContent = T.Text
type PasteVisibility = Bool
                     
data Paste = Paste PasteName PasteContent PasteVisibility deriving (Show, Typeable)
makeLenses ''Paste

data AllPasteData = AllPasteData { _users :: M.Map Username UserData, _pastes:: M.Map PasteHash Paste } deriving (Show, Typeable)
makeLenses ''AllPasteData

-- preview (users . (at $ T.pack "miguel") . _Just . userPastes . (ix 2)) allData
-- example of lens magic
-- same as
-- allData ^? users . (at $ T.pack "miguel") . _Just . userPastes . (ix 2)
-- allData & pastes %~ (M.insert (T.pack "sda82n282") apaste)
-- allData & users . (at $ T.pack "miguel") . _Just . userPastes %~ (T.pack "sda82n282" :)

data AuthenticationStatus = NotValidUser | NotValidPassword | Authenticated deriving (Eq, Show)

getAllData :: Query AllPasteData AllPasteData
getAllData = ask

putAllData :: AllPasteData -> Update AllPasteData ()
putAllData = ST.put

addPaste :: T.Text -> Paste -> Maybe T.Text -> Update AllPasteData ()
addPaste pastehash paste maybeUsername = ST.modify addPaste' where
  addPaste' allPasteData = data1 & maybe id (\username -> users . (at username) . _Just . userPastes %~ (pastehash :) ) maybeUsername where --add paste hash to user
    data1 = allPasteData & pastes %~ (M.insert pastehash paste) --add paste                                  

deriveSafeCopy 0 'base ''Paste
deriveSafeCopy 0 'base ''UserData                
deriveSafeCopy 0 'base ''AllPasteData
makeAcidic ''AllPasteData ['getAllData, 'putAllData, 'addPaste]


allData :: AllPasteData
allData = AllPasteData { _users = theusers, _pastes = M.empty } where
  theusers = M.fromList [("miguel", UserData { _userPassword = "test", _userPastes = [] }) ]

authenticate :: T.Text -> T.Text -> AuthenticationStatus
authenticate username password = maybe NotValidUser (\x -> if _userPassword x == password then Authenticated else NotValidPassword ) maybeUserdata
                                 where maybeUserdata = M.lookup username $ _users allData

--       liftIO $ update acid $ UpdateElement key value
--       maybevalue <- liftIO $ query acid $ GetElement key
  
tsl = TL.pack . T.unpack

main :: IO ()
main = scotty 3000 $ do
  acid <- liftIO $ openLocalStateFrom "state/" allData
  sm <- createSessionManager
  get "/" $ do
    maybeUsername <- readSession sm
    html $ renderText $ html_ $ mainPage maybeUsername
  post "/" $ do
    maybeUsername <- readSession sm
    pasteName <- param "name"
    pasteText <- param "pastedtext"
    let
      textHash = hexSha256 pasteText
    liftIO $ update acid $ AddPaste textHash (Paste pasteName pasteText True) maybeUsername
    status movedPermanently301
    setHeader "Location" $ tsl $ mconcat ["/p/",textHash]
  get "/login" $ do
    html $ renderText $ html_ $ loginHtml
  post "/login" $ do
    username <- param "username"
    password <- param "password"
    let
      astatus = authenticate username password
      message = case astatus of
        NotValidUser -> "user doesn't exist !"
        NotValidPassword -> "wrong password !"
        Authenticated -> "authenticated !"
      messageAndLogin = do
        h1_ $ message
        loginHtml
    case astatus of
     Authenticated -> do
       modifySession sm $ const (Just username::Maybe T.Text)
       status movedPermanently301
       setHeader "Location" "/"
     _ -> html $ renderText $ html_ messageAndLogin
  get "/logout" $ do
    status movedPermanently301
    setHeader "Location" "/"
    sdata <- readSession sm
    modifySession sm $ const Nothing
    html $ renderText $ html_ $ h1_ $ toHtml $ maybe "Not logged in" (\username -> mconcat [username, " logged out."]) sdata
  get "/p/:hash" $ do
    urlhash <- param "hash"
    adata <- liftIO $ query acid $ GetAllData
    let
      maybePaste = M.lookup urlhash $ _pastes adata
      --withPaste :: Paste -> HtmlT Identity ()
      withPaste (Paste n t _) = h1_ $ do  --mconcat [ "this is the url hash: ", urlhash::T.Text ]
        h1_ $ toHtml n
        pre_ $ toHtml t
    html $ renderText $ html_ $ do
      p_ $ do
        linkhome
        " "
        linkpastes
      maybe ("hash doesn't match anything") withPaste maybePaste
  get "/pastes" $ do
    maybeUsername <- readSession sm
    adata <- liftIO $ query acid $ GetAllData
    html $ renderText $ html_ $ maybe pastesPageNoUser (pastesHtmlForUser adata) maybeUsername
  where
    linkhome = a_ [ href_ "/"] "home"
    linkpastes = a_ [ href_ "/pastes" ] "my pastes"
    loginHtml = do
      h3_ "login:"
      form_ [method_ "post", action_ "/login" ] $ do
        p_ $ do
          "Username: "
          input_ [ name_ "username", type_ "text", label_ "username" ]
        p_ $ do
          "password: "
          input_ [ name_ "password", type_ "text" ]
        p_ $ input_ [ type_ "submit" ]
    getTextForm = div_ $ form_ [method_ "post", action_ "/" ] $ do
      p_ $ do
        "Paste name:"
        input_ [name_ "name", type_ "text"]
      textarea_ [name_ "pastedtext", rows_ "20", cols_ "60" ] ""
      p_ $ input_ [type_ "submit", value_ "Submit" ]
    mainPage maybeUsername = do
      h1_ "Pastebox since... now"
      let loggedInLinks = do
            linkpastes
            "  "
            a_ [ href_ "logout" ] "logout"
      h2_ $ if isJust maybeUsername then loggedInLinks else a_ [ href_ "login" ] "login"
      getTextForm
    pastesHtmlForUser :: AllPasteData -> T.Text -> HtmlT Identity ()
    pastesHtmlForUser adata username = do
      let hashes = fromMaybe [] $ adata ^? (users . (at username) . _Just . userPastes)
      p_ linkhome
      ul_ $ mapM_ (\pastehash -> li_ $ a_ [ href_ $ mconcat ["p/",pastehash] ] $ toHtml pastehash ) hashes
    pastesPageNoUser = h3_ $ do
      "User not logged, can't show pastes. Go back to "
      linkhome