[refactor Web.hs into smaller modules Jeremy Shaw **20110707194442 Ignore-this: 615c49db799a38d28d5b4ebb463cec4f ] addfile ./ConfigT.hs hunk ./ConfigT.hs 1 +{-# LANGUAGE GeneralizedNewtypeDeriving, TypeFamilies #-} +module ConfigT where + +import Control.Applicative +import Control.Monad +import Control.Monad.Reader +import Control.Monad.Trans +import Happstack.Server +import HSX.XMLGenerator +import Web.Routes + +newtype ConfigT config m a = ConfigT { runConfigT :: ReaderT config m a } + deriving (Functor, Applicative, Alternative, MonadPlus, Monad, MonadIO, MonadTrans) + +mapConfigT :: (m a -> n b) -> ConfigT config m a -> ConfigT config n b +mapConfigT f (ConfigT r) = ConfigT (mapReaderT f r) + +class MonadConfig m where + type ConfigType m + askConfig :: m (ConfigType m) + localConfig :: (ConfigType m -> ConfigType m) -> m a -> m a + +instance (Monad m) => MonadConfig (ConfigT c m) where + type ConfigType (ConfigT c m) = c + askConfig = ConfigT ask + localConfig f (ConfigT r) = ConfigT (local f r) + +instance (Monad m, MonadConfig m) => MonadConfig (RouteT url m) where + type ConfigType (RouteT url m) = ConfigType m + askConfig = lift askConfig + localConfig f = mapRouteT (localConfig f) + +instance (Monad m, MonadConfig m) => MonadConfig (ServerPartT m) where + type ConfigType (ServerPartT m) = ConfigType m + askConfig = lift askConfig + localConfig f = mapServerPartT (localConfig f) + +instance (Monad m, MonadConfig m) => MonadConfig (XMLGenT m) where + type ConfigType (XMLGenT m) = ConfigType m + askConfig = lift askConfig + localConfig f (XMLGenT m) = XMLGenT (localConfig f m) hunk ./Main.hs 22 -import Web (Config(..),webImpl) +import Server (Config(..)) +import Web (webImpl) adddir ./Pages addfile ./Pages/Admin.hs hunk ./Pages/Admin.hs 1 +{-# LANGUAGE FlexibleContexts, TypeFamilies #-} +{-# OPTIONS_GHC -F -pgmFtrhsx #-} +module Pages.Admin where + +import qualified Data.Text as Text +import Happstack.Server +import HSP +import Pages.AppTemplate +import Server +import Types +import URL +import Web.Routes + +adminPage :: Server Response +adminPage = + do homeURL <- showURL $ W_Board (BoardName $ Text.pack "codez") Nothing + (ok . toResponse) =<< (unXMLGenT $ appTemplate "Super Secret Lair" () $ +
+

You are now an almighty admin

+

Continue your adventure here

+
) + addfile ./Pages/AppTemplate.hs hunk ./Pages/AppTemplate.hs 1 +{-# LANGUAGE FlexibleContexts, TypeFamilies #-} +{-# OPTIONS_GHC -F -pgmFtrhsx #-} +module Pages.AppTemplate where + +import Happstack.Server +import HSP +import HSP.Google.Analytics(analytics) +import HJScript +import qualified HSX.XMLGenerator as HSX +import UACCT (uacct) +import Web.Routes +import Web.Routes.XMLGenT () +import Web.Routes.Happstack () +import Happstack.Server.HSX () + + + +appTemplate :: + ( Functor m + , XMLGenerator m + , EmbedAsChild m headers + , EmbedAsChild m body + , EmbedAsChild m () + , (HSX.XML m) ~ XML + ) + => String -- ^ title + -> headers -- ^ extra tags to include in \ + -> body -- ^ contents to put inside \ + -> XMLGenT m (HSX.XML m) +appTemplate title headers body = + + + + + + <% title %> + <% headers %> + + + <% body %> + <% case uacct of + (Just u) -> <% analytics u %> + Nothing -> <% () %> + %> + + + +seeOtherURL :: (XMLGenerator m, FilterMonad Response m, ShowURL m) => URL m -> XMLGenT m (HSX.XML m) +seeOtherURL url = + do otherURL <- showURL url + seeOther otherURL () + <% otherURL %> + +seeOtherXML :: (XMLGenerator m, FilterMonad Response m) => String -> XMLGenT m (HSX.XML m) +seeOtherXML url = + seeOther url =<< <% url %> + + +embedScript :: (XMLGenerator m) => HJScript () -> GenChildList m +embedScript b = + asChild $ + addfile ./Pages/Board.hs hunk ./Pages/Board.hs 1 +{-# LANGUAGE FlexibleContexts, TypeFamilies #-} +{-# OPTIONS_GHC -F -pgmFtrhsx #-} +module Pages.Board where + +import ConfigT +import Control.Applicative +import Control.Applicative.Error +import Control.Monad +import Control.Monad.Trans +import Data.Text (Text) +import qualified Data.Text as Text +import Data.Time +import Data.Acid hiding (update, query) +import Data.Maybe (fromMaybe, mapMaybe) +import qualified Data.ByteString.Lazy as B +import qualified Data.ByteString.Lazy.Char8 as C +import Data.List +import Happstack.Data.IxSet ((@=)) +import qualified Happstack.Data.IxSet as IxSet +import Happstack.Server +import HJScript.DOM (Node, alert, document, window) +import HJScript.Utils () +import HJScript hiding ((<|>)) +import HJScript.Objects.JQuery hiding (submit) +import HSP +import qualified HSX.XMLGenerator as HSX +import Pages.AppTemplate +import Server +import State +import System.Locale +import Text.Formlets (Form, File(fileName, content), Rect(..), check, checkM, plug, xml) +import HSP.Formlets (checkboxes, input, label, submit, file, password, submit, textarea) +import Happstack.Server.Formlets (formletPart, handleFailure) +import Types +import URL +import Web.Routes + +boardPage :: WebURL -> BoardName -> (Maybe Int) -> Server Response +boardPage here boardName mPage = + do res <- query (GetThreads (fromMaybe 0 mPage) boardName) + case res of + (Left e) -> error (show e) + (Right (threads, maxPageNum)) -> + do let media = mapMaybe medium (concatMap posts threads) + mediaJS <- imageToggles media + let script = embedScript (ready' mediaJS) + toResponse <$> (unXMLGenT $ boardTemplate here (Right (boardName, maxPageNum)) (Text.unpack (unBoardName boardName)) script <% mapM threadHTML threads %>) + +boardTemplate :: + ( EmbedAsChild Server headers + , EmbedAsChild Server body + ) => + WebURL + -> (Either ThreadId (BoardName, Int)) + -> String -- ^ title + -> headers -- ^ extra tags to include in \ + -> body -- ^ contents to put inside \ + -> XMLGenT Server XML +boardTemplate here@(W_Board _ mPage) postType title headers body = + do config <- askConfig + login <- case role config of + User -> + do loginURL <- showURL (W_Login here) + login + Moderator -> + do moderatorURL <- showURL W_Moderator + moderator + Admin -> + do adminURL <- showURL W_Admin + admin + hereURL <- showURL here + bds <- query AskBoards + appTemplate title headers +
+ <% login %> + <% boardLinks bds %> + <% boardTitle bds %> +
+ <% formletPart hereURL handleSuccess handleFailure' (postFormlet `checkM` (validateNewThread config)) %> +
+ <% body %> + <% pageNavigator %> +
+ where + boardLinks bds = + do links <- mapM boardLink (IxSet.toList bds) + [ <% intersperse (pcdata " / ") $ links %> ] + boardLink board = + do l <- showURL (W_Board (BoardName (name board)) Nothing) + <% Text.unpack (abbrev board) %> + boardTitle bds = + case postType of + (Left threadId) -> +

Reply Mode

+ (Right (boardName, _)) -> + case IxSet.getOne (bds @= boardName) of + Nothing ->

<% Text.unpack (unBoardName boardName) %>

+ (Just board) ->

/<% Text.unpack $ abbrev board %>/ - <% Text.unpack $ name board %>

+ pageNavigator = + case postType of + (Left _) -> return (pcdata "") + (Right (boardName, maxPageNum)) -> + do let currentPage = fromMaybe 0 mPage + pageURLs <- mapM (\n -> showURL (W_Board boardName (Just n))) [0..maxPageNum] +
+

Goto page:

+
    <% mapM (\(n, url) -> + if (n == currentPage) + then
  • [<% show n %>]
    • + else
  • [<% show n %>]
    • + ) (zip [0..maxPageNum] pageURLs) %> +
+
+ + handleSuccess c@(name, tripcode, subject, medium, msg) = + case postType of + (Right (boardName, _)) -> + do now <- liftIO $ getCurrentTime + res <- update (NewThread now boardName name tripcode subject medium msg) + case res of + (Left (InvalidBoardName (BoardName bn))) -> + do maybe (return True) expireMedium medium + internalServerError =<< (appTemplate "Internal Error" ()
Internal Error: Invalid Board Name: <% Text.unpack bn %>
) + (Right _thread) -> + seeOtherURL here + (Left threadId) -> + do now <- liftIO $ getCurrentTime + res <- update (ReplyThread now threadId name tripcode subject medium msg) + case res of + (Left InvalidId) -> + notFound =<< appTemplate "404 Not Found" ()

The thread you are trying to reply to does not exist.

+ (Right post) -> + do seeOtherURL here + handleFailure' errs frmXML = handleFailure (\t b -> appTemplate t () b) errs frmXML + +validateNewThread :: (MonadIO m) => Config -> (String, String, String, File, String) -> m (Failing (Maybe Text, Maybe String, Maybe Text, Maybe Medium, Text)) +validateNewThread config (name, tripCode, subject, file, msg) = + if (B.null (content file) || null msg) + then return $ Failure ["You must supply and image and a comment to start a new thread."] + else do medium <- saveImage (acid config) (storageDir config) (fileName file) (C.unpack $ content file) + return $ Success $ (maybeText name, maybeString tripCode, maybeText subject, Just medium, Text.pack msg) + where + maybeString :: String -> Maybe String + maybeString [] = Nothing + maybeString str = Just str + maybeText :: String -> Maybe Text + maybeText = fmap Text.pack . maybeString + + +threadHTML :: (XMLGenerator m, ShowURL m, URL m ~ WebURL, EmbedAsChild m ()) => Thread -> XMLGenT m (HSX.XML m) +threadHTML thread = + do replyURL <- showURL (W_Reply (threadId thread)) +
+ <% case (posts thread) of + [] ->

Odd. This thread does not contain any posts.

+ (h:t) -> +
    + <% sequence $ (postHTML True h) : (map (postHTML False) t) %> +
+ %> +

[ Reply ]

+
+ +-- unpacking Text to String and then later converting it to a ByteString seems wrong. We should go straight to BS perhaps? Though, maybe not. +postHTML :: (XMLGenerator m, EmbedAsChild m (), ShowURL m, URL m ~ WebURL) => Bool -> Post -> XMLGenT m (HSX.XML m) +postHTML first post = do +
  • +

    <% maybe "Anonymous" Text.unpack (poster post) %> <% maybe "" Text.unpack (subject post) %> <% formatTime defaultTimeLocale rfc822DateFormat (posted post) %> No.<% show $ unPostId $ postId post %>

    + <% case medium post of + Nothing -> <% () %> + (Just medium) -> <%
    <% mediumHTML medium %>
    %> + %> +

    <% Text.unpack (msg post) %>

    +
    • + +mediumHTML :: (ShowURL m, XMLGenerator m, URL m ~ WebURL) => Medium -> XMLGenT m (HSX.XML m) +mediumHTML img@(Image {}) = + do imgThumbnailURL <- showURL (W_Image (mediumId img) Thumbnail (uploadName img)) + imgURL <- showURL (W_Image (mediumId img) FullSize (uploadName img)) + + +postFormlet :: (XMLGenerator x, Applicative v, Monad v) => Form [XMLGenT x (HSX.XML x)] v (String, String, String, File, String) +postFormlet = + (,,,,) <$> + (label "Name" *> input Nothing <* br ) <*> + (label "Password" *> password Nothing <* span "(optional)" <* br) <*> + (label "Subject" *> input Nothing <* br) <*> + (label "Image" *> file <* br) <*> + (textarea (const (Rect 60 8)) Nothing <* br) <* + (submit "Post") + where + br = xml [
    ] + span c = xml [<% c %>] + +imageToggleJS :: (WebURL ~ URL m, ShowURL m, Monad m) => Medium -> m (HJScript (Exp JQuery)) +imageToggleJS img@Image{} = + do fullURL <- showURL (W_Image (mediumId img) FullSize (storedName img)) + thumbnailURL <- showURL (W_Image (mediumId img) Thumbnail ("t_" ++ storedName img)) + return $ itjs (mediumId img) fullURL thumbnailURL + +jSetAttr :: (JString, JString) -> JObject JQuery -> JObject JQuery +jSetAttr = methodCall "attr" + +toggle2 :: (Exp (() -> ()), Exp (() -> ())) -> Exp JQuery -> Exp JQuery +toggle2 = callMethod "toggle" + + +itjs :: MediumId -> String -> String -> HJScript (Exp JQuery) +itjs mediumId fullURL thumbnailURL = + do full <- procedure $ \() -> runExp $ selectExpr (this :: JObject Node) # jSetAttr (string "src", string fullURL) + thumb <- procedure $ \() -> runExp $ selectExpr (this :: JObject Node) # jSetAttr (string "src", string thumbnailURL) + return $ selectExpr (string $ "#medium_" ++ show (unMediumId mediumId)) # toggle2 (full, thumb) + +imageToggles :: (WebURL ~ URL m, ShowURL m, Monad m) => [Medium] -> m (HJScript ()) +imageToggles media = + do js <- mapM imageToggleJS media + return $ mapM_ (runExp =<<) js + +ready' :: HJScript () -> HJScript () +ready' script + = do fn <- procedure $ \() -> script + runExp $ selectExpr document # readyFn fn + +readyFn :: Exp (() -> ()) -> JObject JQuery -> Exp () +readyFn = methodCall "ready" addfile ./Pages/FormPart.hs hunk ./Pages/FormPart.hs 1 +{-# LANGUAGE FlexibleContexts #-} +{-# OPTIONS_GHC -F -pgmFtrhsx #-} +module Pages.FormPart + ( formPart + , notEmpty +{- + , fieldset + , ol + , li + , minLengthString + , minLengthText +-} + ) where hunk ./Pages/FormPart.hs 15 +import Control.Applicative (Alternative, optional) +import Control.Monad +import Control.Monad.Trans +import qualified Data.Text as Text +import Data.Text (Text) +import Happstack.Server +import HSP (XMLGenT(..), Attr(..), EmbedAsAttr(..), EmbedAsChild(..), genElement, mapXMLGenT) +import Happstack.Server.HSX () -- instance (ServerMonad XMLGenT) +import qualified HSX.XMLGenerator as HSX +import Text.Digestive +import Text.Digestive.Forms.Happstack (happstackEnvironment) +import Text.Digestive.HSP.Html4 + +-- |turn a formlet into XML+ServerPartT which can be embedded in a larger document +formPart :: + (EmbedAsChild m xml, EmbedAsAttr m (Attr String String), ToMessage b, Happstack m, Alternative m) => + String -- ^ prefix + -> String -- ^ url to POST form results to + -> (a -> m b) -- ^ handler used when form validates + -> Maybe ([(FormRange, e)] -> [XMLGenT m (HSX.XML m)] -> m b) -- ^ handler used when form does not validate + -> Form (XMLGenT m) [Input] e xml a -- ^ the formlet + -> XMLGenT m (HSX.XML m) +formPart prefix action handleSuccess mHandleFailure form = + msum [ do methodM [GET, HEAD] + (v, _) <- runForm form prefix NoEnvironment +
    + <% unView v [] %> +
    + , do methodM POST + (v,r) <- runForm form prefix $ happstackEnvironment + case r of + (Ok a) -> XMLGenT $ (escape . fmap toResponse) $ handleSuccess a + (Error e) -> + case mHandleFailure of + (Just handleFailure) -> + XMLGenT $ (escape . fmap toResponse) $ + handleFailure e [
    + <% unView v e %> +
    + ] + Nothing -> +
    + <% unView v e %> +
    + ] + +notEmpty :: (Monad m) => Validator m String Text +notEmpty = (check "field can not be empty") (not . Text.null) +{- +fieldset :: PhotographyForm a -> PhotographyForm a +fieldset = mapView $ \xml -> [
    <% xml %>
    ] + +ol :: PhotographyForm a -> PhotographyForm a +ol = mapView $ \xml -> [
      <% xml %>
    ] + +li :: PhotographyForm a -> PhotographyForm a +li = mapView $ \xml -> [
  • <% xml %>
    • ] + +minLengthText :: Int -> PhotographyForm Text -> PhotographyForm Text +minLengthText 0 f = f +minLengthText 1 f = errors ++> (f `validate` (check "This field can not be empty." (not . Text.null))) +minLengthText n f = errors ++> (f `validate` (check ("This field must be at least " ++ show n ++ " characters.") (\t -> Text.length t >= n))) + +minLengthString :: Int -> PhotographyForm String -> PhotographyForm String +minLengthString 0 f = f +minLengthString 1 f = errors ++> (f `validate` (check "This field can not be empty." (not . null))) +minLengthString n f = errors ++> (f `validate` (check ("This field must be at least " ++ show n ++ " characters.") (\t -> length t >= n))) +-} addfile ./Pages/Image.hs hunk ./Pages/Image.hs 1 +module Pages.Image where + +import ConfigT +import Happstack.Server +import HSP +import Pages.AppTemplate +import Server +import State +import Types +import URL + +imagePage :: MediumId -> Size -> Server Response +imagePage mediumId size = + do config <- askConfig + res <- requestFilteredImage (acid config) (ioThread config) mediumId size + case res of + (Left InvalidId) -> + (notFound . toResponse) =<< (unXMLGenT $ appTemplate "Not Found" () "The image you are looking for does not exist.") + (Right imageFP) -> + serveFile (asContentType "image/jpeg") imageFP addfile ./Pages/Login.hs hunk ./Pages/Login.hs 1 +{-# LANGUAGE FlexibleContexts, TypeFamilies #-} +{-# OPTIONS_GHC -F -pgmFtrhsx #-} +module Pages.Login where + +import Control.Applicative +import Control.Applicative.Error +import Control.Monad.Trans +import ConfigT +import Data.Acid +import State +import Server +import Types +import URL +import Pages.AppTemplate +import Happstack.Crypto.SHA1 (sha1) +import Happstack.Server +import HSP +import qualified HSX.XMLGenerator as HSX +import Web.Routes +import Text.Formlets (Form, File(fileName, content), Rect(..), check, checkM, plug, xml) +import HSP.Formlets (checkboxes, input, label, submit, file, password, submit, textarea) +import Happstack.Server.Formlets (formletPart, handleFailure) +import System.Random + +loginPage :: WebURL -> WebURL -> Server Response +loginPage here dest = + do hereURL <- showURL here + a <- acid <$> askConfig + (ok . toResponse) =<< (unXMLGenT $ appTemplate "Login" () $ + <% formletPart hereURL handleSuccess handleFailure' (loginForm `checkM` (verifyPassword a)) %>) + where + verifyPassword acid (username, password) = + do r <- query' acid (CheckPassword username password) + case r of + (Left InvalidLogin) -> return $ Failure ["Invalid Login"] + (Right role) -> return $ Success role + handleSuccess role = + do config <- askConfig + i <- liftIO $ (randomIO :: IO Int) + addCookie Session (mkCookie "secret" (show i)) + addCookie Session (mkCookie "role" (show role)) + destURL <- authURL (appSecret config) (show i) role dest + seeOtherXML destURL + handleFailure' errs frmXML = handleFailure (\t b -> appTemplate t () b) errs frmXML + + +loginForm :: (XMLGenerator x, Applicative v, Monad v) => Form [XMLGenT x (HSX.XML x)] v (String, String) +loginForm = + (,) <$> (label "Username" *> input Nothing <* br) <*> + (label "Password" *> password Nothing <* br) <* submit "Login" + where + br = xml [
    ] + +authURL :: (Monad m, ShowURL m) => String -> String -> Role -> URL m -> m Link +authURL appSecret userSecret role url = + do link <- showURL url + let authKey = sha1 (appSecret ++ userSecret ++ show role ++ link) + return $ (link ++ "?auth=" ++ authKey :: String) addfile ./Pages/Moderator.hs hunk ./Pages/Moderator.hs 1 +{-# LANGUAGE FlexibleContexts, TypeFamilies #-} +{-# OPTIONS_GHC -F -pgmFtrhsx #-} +module Pages.Moderator where + +import qualified Data.Text as Text +import Happstack.Server +import Happstack.Server.HSP.HTML +import HSP +import Pages.AppTemplate +import Server +import Types +import URL +import Web.Routes + +moderatorPage :: Server Response +moderatorPage = + do homeURL <- showURL $ W_Board (BoardName $ Text.pack "codez") Nothing + (ok . toResponse) =<< (unXMLGenT $ appTemplate "Super Secret Lair" () $ +
    +

    You are in the moderator's lair.

    +

    Continue your adventure here

    +
    ) + addfile ./Pages/Reply.hs hunk ./Pages/Reply.hs 1 +{-# LANGUAGE FlexibleContexts, TypeFamilies #-} +{-# OPTIONS_GHC -F -pgmFtrhsx #-} +module Pages.Reply where + +import Data.Maybe +import Happstack.Server +import HSP +import Pages.AppTemplate +import Pages.Board +import State +import Server +import Types +import URL + +replyPage :: WebURL -> ThreadId -> Server Response +replyPage here threadId = + do res <- query (GetThread threadId) + case res of + (Left e) -> (notFound . toResponse) =<< (unXMLGenT $ appTemplate "404 Not Found" ()

    The thread <% show threadId %> does not exist.

    ) + (Right thread) -> + do let media = mapMaybe medium (posts thread) + (ok . toResponse) =<< (unXMLGenT $ boardTemplate here (Left threadId) ("Thread " ++ show (unThreadId threadId)) () <% threadHTML thread %>) + addfile ./Server.hs hunk ./Server.hs 1 +{-# LANGUAGE TypeFamilies #-} +module Server where + +import Control.Monad +import Control.Monad.Trans +import ConfigT +import Data.Acid +import Data.Acid.Core +import Extra.IOThread +import Happstack.Server +import State +import Types +import URL +import Web.Routes + +data Config = Config { storageDir :: FilePath + , cacheDir :: FilePath + , ioThread :: IOThread (Medium, Size) FilePath + , appSecret :: String + , role :: Role + , acid :: AcidState State + } + +type Server = RouteT WebURL (ServerPartT (ConfigT Config IO)) + + +query :: (ConfigType m ~ Config, MonadIO m, MonadConfig m, QueryEvent ev, MethodState ev ~ State) => ev -> m (EventResult ev) +query ev = + do a <- liftM acid askConfig + query' a ev + +update :: (ConfigType m ~ Config, MonadIO m, MonadConfig m, UpdateEvent ev, MethodState ev ~ State) => ev -> m (EventResult ev) +update ev = + do a <- liftM acid askConfig + update' a ev addfile ./URL.hs hunk ./URL.hs 1 +{-# LANGUAGE DeriveDataTypeable #-} +module URL where + +import Control.Applicative +import Control.Monad +import Data.Data +import Data.Text (Text) +import qualified Data.Text as Text +import Test.QuickCheck +import Types +import Web.Routes + +data WebURL + = W_Board BoardName (Maybe Int) + | W_Image MediumId Size String + | W_Reply ThreadId + | W_Login WebURL + | W_Moderator + | W_Admin + deriving (Read, Show, Eq, Ord, Typeable, Data) + +instance PathInfo WebURL where + toPathSegments (W_Board (BoardName boardName) mPage) = + ["board", Text.unpack boardName] ++ (maybe ["0"] ((:[]) . show) mPage) + toPathSegments (W_Image (MediumId mediumId) size uploadName) = + ["images", show mediumId, case size of Thumbnail -> "thumbnail" ; FullSize -> "full", uploadName ] + toPathSegments (W_Reply (ThreadId threadId)) = + ["thread", show threadId] + toPathSegments (W_Login dest) = + "login" : (toPathSegments dest) + toPathSegments W_Moderator = + ["moderator"] + toPathSegments W_Admin = + ["admin"] + fromPathSegments = + msum [ do segment "board" + bn <- anySegment + p <- fmap read anySegment -- this should use something that returns a proper error when not an int + return $ W_Board (BoardName (Text.pack bn)) (case p of 0 -> Nothing ; _ -> Just p) + , do segment "images" + mid <- fmap read anySegment + size <- (segment "thumbnail" >> return Thumbnail) `mplus` (segment "full" >> return FullSize) + name <- anySegment + return $ W_Image (MediumId mid) size name + , do segment "thread" + tid <- fmap read anySegment + return $ W_Reply (ThreadId tid) + , do segment "login" + dest <- fromPathSegments + return $ W_Login dest + , do segment "moderator" + return W_Moderator + , do segment "admin" + return W_Admin + ] + +instance Arbitrary BoardName where + arbitrary = (BoardName . Text.pack) <$> (arbitrary `suchThat` (not . null)) + +instance Arbitrary Size where + arbitrary = elements [FullSize .. Thumbnail] + +instance Arbitrary WebURL where + arbitrary = oneof [ W_Board <$> arbitrary <*> (do { n <- arbitrary ; case n of 0 -> return Nothing ; _ -> return (Just n) }) + , W_Image <$> (MediumId <$> arbitrary) <*> arbitrary <*> (arbitrary `suchThat` (not .null)) + , W_Reply <$> (ThreadId <$> arbitrary) + , W_Login <$> arbitrary + , pure W_Moderator + , pure W_Admin + ] + +-- to use run, quickCheck url_prop +url_prop :: Property +url_prop = property (pathInfoInverse_prop :: WebURL -> Bool) hunk ./Web.hs 9 +import ConfigT hunk ./Web.hs 40 +import Pages.AppTemplate +import Pages.Board (boardPage) +import Pages.Image (imagePage) +import Pages.Reply (replyPage) +import Pages.Login (loginPage) +import Pages.Moderator (moderatorPage) +import Pages.Admin (adminPage) hunk ./Web.hs 51 +import Server hunk ./Web.hs 56 +import URL hunk ./Web.hs 61 -data WebURL - = W_Board BoardName (Maybe Int) - | W_Image MediumId Size String - | W_Reply ThreadId - | W_Login WebURL - | W_Moderator - | W_Admin - deriving (Read, Show, Eq, Ord, Typeable, Data) - -newtype ConfigT m a = ConfigT { runConfigT :: ReaderT Config m a } - deriving (Functor, Applicative, Alternative, MonadPlus, Monad, MonadIO, MonadTrans) - -mapConfigT :: (m a -> n b) -> ConfigT m a -> ConfigT n b -mapConfigT f (ConfigT r) = ConfigT (mapReaderT f r) - -class MonadConfig m where - askConfig :: m Config - localConfig :: (Config -> Config) -> m a -> m a - -instance (Monad m) => MonadConfig (ConfigT m) where - askConfig = ConfigT ask - localConfig f (ConfigT r) = ConfigT (local f r) - -instance (Monad m, MonadConfig m) => MonadConfig (RouteT url m) where - askConfig = lift askConfig - localConfig f = mapRouteT (localConfig f) - -instance (Monad m, MonadConfig m) => MonadConfig (ServerPartT m) where - askConfig = lift askConfig - localConfig f = mapServerPartT (localConfig f) - -instance (Monad m, MonadConfig m) => MonadConfig (XMLGenT m) where - askConfig = lift askConfig - localConfig f (XMLGenT m) = XMLGenT (localConfig f m) - -instance PathInfo WebURL where - toPathSegments (W_Board (BoardName boardName) mPage) = - ["board", Text.unpack boardName] ++ (maybe ["0"] ((:[]) . show) mPage) - toPathSegments (W_Image (MediumId mediumId) size uploadName) = - ["images", show mediumId, case size of Thumbnail -> "thumbnail" ; FullSize -> "full", uploadName ] - toPathSegments (W_Reply (ThreadId threadId)) = - ["thread", show threadId] - toPathSegments (W_Login dest) = - "login" : (toPathSegments dest) - toPathSegments W_Moderator = - ["moderator"] - toPathSegments W_Admin = - ["admin"] - fromPathSegments = - msum [ do segment "board" - bn <- anySegment - p <- fmap read anySegment -- this should use something that returns a proper error when not an int - return $ W_Board (BoardName (Text.pack bn)) (case p of 0 -> Nothing ; _ -> Just p) - , do segment "images" - mid <- fmap read anySegment - size <- (segment "thumbnail" >> return Thumbnail) `mplus` (segment "full" >> return FullSize) - name <- anySegment - return $ W_Image (MediumId mid) size name - , do segment "thread" - tid <- fmap read anySegment - return $ W_Reply (ThreadId tid) - , do segment "login" - dest <- fromPathSegments - return $ W_Login dest - , do segment "moderator" - return W_Moderator - , do segment "admin" - return W_Admin - ] - -instance Arbitrary BoardName where - arbitrary = (BoardName . Text.pack) <$> (arbitrary `suchThat` (not . null)) - -instance Arbitrary Size where - arbitrary = elements [FullSize .. Thumbnail] - -instance Arbitrary WebURL where - arbitrary = oneof [ W_Board <$> arbitrary <*> (do { n <- arbitrary ; case n of 0 -> return Nothing ; _ -> return (Just n) }) - , W_Image <$> (MediumId <$> arbitrary) <*> arbitrary <*> (arbitrary `suchThat` (not .null)) - , W_Reply <$> (ThreadId <$> arbitrary) - , W_Login <$> arbitrary - , pure W_Moderator - , pure W_Admin - ] - --- to use run, quickCheck url_prop -url_prop :: Property -url_prop = property (pathInfoInverse_prop :: WebURL -> Bool) - -data Config = Config { storageDir :: FilePath - , cacheDir :: FilePath - , ioThread :: IOThread (Medium, Size) FilePath - , appSecret :: String - , role :: Role - , acid :: AcidState State - } - -type Server = RouteT WebURL (ServerPartT (ConfigT IO)) - -query :: (MonadIO m, MonadConfig m, QueryEvent ev, MethodState ev ~ State) => ev -> m (EventResult ev) -query ev = - do a <- liftM acid askConfig - query' a ev - -update :: (MonadIO m, MonadConfig m, UpdateEvent ev, MethodState ev ~ State) => ev -> m (EventResult ev) -update ev = - do a <- liftM acid askConfig - update' a ev - -embedScript :: (XMLGenerator m) => HJScript () -> GenChildList m -embedScript b = - asChild $ - - hunk ./Web.hs 62 -web here@(W_Board boardName mPage) = - do res <- query (GetThreads (fromMaybe 0 mPage) boardName) - case res of - (Left e) -> error (show e) - (Right (threads, maxPageNum)) -> - do let media = mapMaybe medium (concatMap posts threads) - mediaJS <- imageToggles media - let script = embedScript (ready' mediaJS) - toResponse <$> (unXMLGenT $ boardTemplate here (Right (boardName, maxPageNum)) (Text.unpack (unBoardName boardName)) script <% mapM threadHTML threads %>) - -web here@(W_Reply threadId) = - do res <- query (GetThread threadId) - case res of - (Left e) -> (notFound . toResponse) =<< (unXMLGenT $ appTemplate "404 Not Found" ()

    The thread <% show threadId %> does not exist.

    ) - (Right thread) -> - do let media = mapMaybe medium (posts thread) - (ok . toResponse) =<< (unXMLGenT $ boardTemplate here (Left threadId) ("Thread " ++ show (unThreadId threadId)) () <% threadHTML thread %>) - -web here@(W_Image mediumId size fn) = - do config <- askConfig - res <- requestFilteredImage (acid config) (ioThread config) mediumId size - case res of - (Left InvalidId) -> - (notFound . toResponse) =<< (unXMLGenT $ appTemplate "Not Found" () "The image you are looking for does not exist.") - (Right imageFP) -> - serveFile (asContentType "image/jpeg") imageFP -web here@(W_Login dest) = - do hereURL <- showURL here - a <- acid <$> askConfig - (ok . toResponse) =<< (unXMLGenT $ appTemplate "Login" () $ - <% formletPart hereURL handleSuccess handleFailure' (loginForm `checkM` (verifyPassword a)) %>) - where - verifyPassword acid (username, password) = - do r <- query' acid (CheckPassword username password) - case r of - (Left InvalidLogin) -> return $ Failure ["Invalid Login"] - (Right role) -> return $ Success role - handleSuccess role = - do config <- askConfig - i <- liftIO $ (randomIO :: IO Int) - addCookie Session (mkCookie "secret" (show i)) - addCookie Session (mkCookie "role" (show role)) - destURL <- authURL (appSecret config) (show i) role dest - seeOtherXML destURL - handleFailure' errs frmXML = handleFailure (\t b -> appTemplate t () b) errs frmXML -web here@W_Moderator = - do homeURL <- showURL $ W_Board (BoardName $ Text.pack "codez") Nothing - (ok . toResponse) =<< (unXMLGenT $ appTemplate "Super Secret Lair" () $ -
    -

    You are in the moderator's lair.

    -

    Continue your adventure here

    -
    ) -web here@W_Admin = - do homeURL <- showURL $ W_Board (BoardName $ Text.pack "codez") Nothing - (ok . toResponse) =<< (unXMLGenT $ appTemplate "Super Secret Lair" () $ -
    -

    You are now an almighty admin

    -

    Continue your adventure here

    -
    ) +web url = + case url of + (W_Board boardName page) -> boardPage url boardName page + (W_Reply threadId) -> replyPage url threadId + (W_Image mediumId size _) -> imagePage mediumId size + (W_Login dest) -> loginPage url dest + W_Moderator -> moderatorPage + W_Admin -> adminPage hunk ./Web.hs 80 -authURL :: (Monad m, ShowURL m) => String -> String -> Role -> URL m -> m Link -authURL appSecret userSecret role url = - do link <- showURL url - let authKey = sha1 (appSecret ++ userSecret ++ show role ++ link) - return $ (link ++ "?auth=" ++ authKey :: String) hunk ./Web.hs 105 -loginForm :: (XMLGenerator x, Applicative v, Monad v) => Form [XMLGenT x (HSX.XML x)] v (String, String) -loginForm = - (,) <$> (label "Username" *> input Nothing <* br) <*> - (label "Password" *> password Nothing <* br) <* submit "Login" - where - br = xml [
    ] - -threadHTML :: (XMLGenerator m, ShowURL m, URL m ~ WebURL, EmbedAsChild m ()) => Thread -> XMLGenT m (HSX.XML m) -threadHTML thread = - do replyURL <- showURL (W_Reply (threadId thread)) -
    - <% case (posts thread) of - [] ->

    Odd. This thread does not contain any posts.

    - (h:t) -> -
      - <% sequence $ (postHTML True h) : (map (postHTML False) t) %> -
    - %> -

    [ Reply ]

    -
    - --- unpacking Text to String and then later converting it to a ByteString seems wrong. We should go straight to BS perhaps? Though, maybe not. -postHTML :: (XMLGenerator m, EmbedAsChild m (), ShowURL m, URL m ~ WebURL) => Bool -> Post -> XMLGenT m (HSX.XML m) -postHTML first post = do -
  • -

    <% maybe "Anonymous" Text.unpack (poster post) %> <% maybe "" Text.unpack (subject post) %> <% formatTime defaultTimeLocale rfc822DateFormat (posted post) %> No.<% show $ unPostId $ postId post %>

    - <% case medium post of - Nothing -> <% () %> - (Just medium) -> <%
    <% mediumHTML medium %>
    %> - %> -

    <% Text.unpack (msg post) %>

    -
    • - -mediumHTML :: (ShowURL m, XMLGenerator m, URL m ~ WebURL) => Medium -> XMLGenT m (HSX.XML m) -mediumHTML img@(Image {}) = - do imgThumbnailURL <- showURL (W_Image (mediumId img) Thumbnail (uploadName img)) - imgURL <- showURL (W_Image (mediumId img) FullSize (uploadName img)) - - -postFormlet :: (XMLGenerator x, Applicative v, Monad v) => Form [XMLGenT x (HSX.XML x)] v (String, String, String, File, String) -postFormlet = - (,,,,) <$> - (label "Name" *> input Nothing <* br ) <*> - (label "Password" *> password Nothing <* span "(optional)" <* br) <*> - (label "Subject" *> input Nothing <* br) <*> - (label "Image" *> file <* br) <*> - (textarea (const (Rect 60 8)) Nothing <* br) <* - (submit "Post") - where - br = xml [
    ] - span c = xml [<% c %>] - -validateNewThread :: (MonadIO m) => Config -> (String, String, String, File, String) -> m (Failing (Maybe Text, Maybe String, Maybe Text, Maybe Medium, Text)) -validateNewThread config (name, tripCode, subject, file, msg) = - if (B.null (content file) || null msg) - then return $ Failure ["You must supply and image and a comment to start a new thread."] - else do medium <- saveImage (acid config) (storageDir config) (fileName file) (C.unpack $ content file) - return $ Success $ (maybeText name, maybeString tripCode, maybeText subject, Just medium, Text.pack msg) - where - maybeString :: String -> Maybe String - maybeString [] = Nothing - maybeString str = Just str - maybeText :: String -> Maybe Text - maybeText = fmap Text.pack . maybeString - -boardTemplate :: - ( EmbedAsChild Server headers - , EmbedAsChild Server body - ) => - WebURL - -> (Either ThreadId (BoardName, Int)) - -> String -- ^ title - -> headers -- ^ extra tags to include in \ - -> body -- ^ contents to put inside \ - -> XMLGenT Server XML -boardTemplate here@(W_Board _ mPage) postType title headers body = - do config <- askConfig - login <- case role config of - User -> - do loginURL <- showURL (W_Login here) - login - Moderator -> - do moderatorURL <- showURL W_Moderator - moderator - Admin -> - do adminURL <- showURL W_Admin - admin - hereURL <- showURL here - bds <- query AskBoards - appTemplate title headers -
    - <% login %> - <% boardLinks bds %> - <% boardTitle bds %> -
    - <% formletPart hereURL handleSuccess handleFailure' (postFormlet `checkM` (validateNewThread config)) %> -
    - <% body %> - <% pageNavigator %> -
    - where - boardLinks bds = - do links <- mapM boardLink (IxSet.toList bds) - [ <% intersperse (pcdata " / ") $ links %> ] - boardLink board = - do l <- showURL (W_Board (BoardName (name board)) Nothing) - <% Text.unpack (abbrev board) %> - boardTitle bds = - case postType of - (Left threadId) -> -

    Reply Mode

    - (Right (boardName, _)) -> - case IxSet.getOne (bds @= boardName) of - Nothing ->

    <% Text.unpack (unBoardName boardName) %>

    - (Just board) ->

    /<% Text.unpack $ abbrev board %>/ - <% Text.unpack $ name board %>

    - pageNavigator = - case postType of - (Left _) -> return (pcdata "") - (Right (boardName, maxPageNum)) -> - do let currentPage = fromMaybe 0 mPage - pageURLs <- mapM (\n -> showURL (W_Board boardName (Just n))) [0..maxPageNum] -
    -

    Goto page:

    -
      <% mapM (\(n, url) -> - if (n == currentPage) - then
    • [<% show n %>]
      • - else
    • [<% show n %>]
      • - ) (zip [0..maxPageNum] pageURLs) %> -
    -
    - - handleSuccess c@(name, tripcode, subject, medium, msg) = - case postType of - (Right (boardName, _)) -> - do now <- liftIO $ getCurrentTime - res <- update (NewThread now boardName name tripcode subject medium msg) - case res of - (Left (InvalidBoardName (BoardName bn))) -> - do maybe (return True) expireMedium medium - internalServerError =<< (appTemplate "Internal Error" ()
    Internal Error: Invalid Board Name: <% Text.unpack bn %>
    ) - (Right _thread) -> - do hereURL <- showURL here - seeOtherXML hereURL - (Left threadId) -> - do now <- liftIO $ getCurrentTime - res <- update (ReplyThread now threadId name tripcode subject medium msg) - case res of - (Left InvalidId) -> - notFound =<< appTemplate "404 Not Found" ()

    The thread you are trying to reply to does not exist.

    - (Right post) -> - do hereURL <- showURL here - seeOtherXML hereURL - handleFailure' errs frmXML = handleFailure (\t b -> appTemplate t () b) errs frmXML - -seeOtherXML :: (XMLGenerator m, FilterMonad Response m) => String -> XMLGenT m (HSX.XML m) -seeOtherXML url = - seeOther url =<< <% url %> - -appTemplate :: - ( Functor m - , XMLGenerator m - , EmbedAsChild m headers - , EmbedAsChild m body - , EmbedAsChild m () - , (HSX.XML m) ~ XML - ) - => String -- ^ title - -> headers -- ^ extra tags to include in \ - -> body -- ^ contents to put inside \ - -> XMLGenT m (HSX.XML m) -appTemplate title headers body = - - - - - - <% title %> - <% headers %> - - - <% body %> - <% case uacct of - (Just u) -> <% analytics u %> - Nothing -> <% () %> - %> - - - -webSpec :: Site WebURL (ServerPartT (ConfigT IO) Response) +webSpec :: Site WebURL (ServerPartT (ConfigT Config IO) Response) hunk ./Web.hs 110 - hunk ./Web.hs 117 -toIO :: (Monad m) => Config -> ServerPartT (ConfigT m) a -> ServerPartT m a +toIO :: (Monad m) => Config -> ServerPartT (ConfigT Config m) a -> ServerPartT m a hunk ./Web.hs 122 - -imageToggleJS :: (WebURL ~ URL m, ShowURL m, Monad m) => Medium -> m (HJScript (Exp JQuery)) -imageToggleJS img@Image{} = - do fullURL <- showURL (W_Image (mediumId img) FullSize (storedName img)) - thumbnailURL <- showURL (W_Image (mediumId img) Thumbnail ("t_" ++ storedName img)) - return $ itjs (mediumId img) fullURL thumbnailURL - -jSetAttr :: (JString, JString) -> JObject JQuery -> JObject JQuery -jSetAttr = methodCall "attr" - -toggle2 :: (Exp (() -> ()), Exp (() -> ())) -> Exp JQuery -> Exp JQuery -toggle2 = callMethod "toggle" - - -itjs :: MediumId -> String -> String -> HJScript (Exp JQuery) -itjs mediumId fullURL thumbnailURL = - do full <- procedure $ \() -> runExp $ selectExpr (this :: JObject Node) # jSetAttr (string "src", string fullURL) - thumb <- procedure $ \() -> runExp $ selectExpr (this :: JObject Node) # jSetAttr (string "src", string thumbnailURL) - return $ selectExpr (string $ "#medium_" ++ show (unMediumId mediumId)) # toggle2 (full, thumb) - -imageToggles :: (WebURL ~ URL m, ShowURL m, Monad m) => [Medium] -> m (HJScript ()) -imageToggles media = - do js <- mapM imageToggleJS media - return $ mapM_ (runExp =<<) js - -ready' :: HJScript () -> HJScript () -ready' script - = do fn <- procedure $ \() -> script - runExp $ selectExpr document # readyFn fn - -readyFn :: Exp (() -> ()) -> JObject JQuery -> Exp () -readyFn = methodCall "ready"