{-# LANGUAGE DeriveDataTypeable, FlexibleContexts, FlexibleInstances, GeneralizedNewtypeDeriving, MultiParamTypeClasses, OverloadedStrings, RecordWildCards, TemplateHaskell, TypeFamilies, TypeSynonymInstances, OverloadedStrings #-} {-# OPTIONS_GHC -F -pgmFhsx2hs #-} module Main where import Happstack.Foundation import qualified Data.IxSet as IxSet import Data.IxSet (IxSet, Indexable, Proxy(..), (@=), getEQ, getOne, ixSet, ixFun) import Data.Text (Text) import qualified Data.Text.Lazy as Lazy import qualified Data.Text as Text import Data.Time.Clock (UTCTime, getCurrentTime) ------------------------------------------------------------------------------ -- Model ------------------------------------------------------------------------------ -- | an id which uniquely identifies a paste -- -- NOTE: 'PasteId 0' indicates that a 'Paste' has not been assigned an -- id yet. Though.. I am not thrilled about 0 having special meaning -- that is not enforced by the type system. newtype PasteId = PasteId { unPasteId :: Integer } deriving (Eq, Ord, Read, Show, Enum, Data, Typeable, SafeCopy) $(derivePathInfo ''PasteId) -- | The format of the paste. Currently we only support plain-text, -- but later we might add support for Haskell syntax hightlighting, -- etc. data Format = PlainText deriving (Eq, Ord, Read, Show, Enum, Bounded, Data, Typeable) $(deriveSafeCopy 0 'base ''Format) -- | the meta-data for a 'Paste' -- -- We break this out separately from the paste, because we often want -- only the meta-data. For example, when generating a list of recent pastes. data PasteMeta = PasteMeta { pasteId :: PasteId , title :: Text , nickname :: Text , format :: Format , pasted :: UTCTime } deriving (Eq, Ord, Read, Show, Data, Typeable) $(deriveSafeCopy 0 'base ''PasteMeta) -- | a 'Paste' data Paste = Paste { pasteMeta :: PasteMeta , paste :: Text } deriving (Eq, Ord, Read, Show, Data, Typeable) $(deriveSafeCopy 0 'base ''Paste) -- | The 'Indexable Paste' instance will allow us to create an 'IxSet Paste' -- -- We index on the 'PasteId' and the time it was pasted. instance Indexable Paste where empty = ixSet [ ixFun $ (:[]) . pasteId . pasteMeta , ixFun $ (:[]) . pasted . pasteMeta ] -- | record to store in acid-state data CtrlVState = CtrlVState { pastes :: IxSet Paste , nextPasteId :: PasteId } deriving (Data, Typeable) $(deriveSafeCopy 0 'base ''CtrlVState) -- | initial value to use with acid-state when no prior state is found initialCtrlVState :: CtrlVState initialCtrlVState = CtrlVState { pastes = IxSet.empty , nextPasteId = PasteId 1 } ------------------------------------------------------------------------------ -- Acid-State events ------------------------------------------------------------------------------ -- | add or update a paste -- -- If the PasteId is '0', then update the paste to use the next unused PasteId and insert it into the IxSet. -- -- Otherwise, we update the existing paste. insertPaste :: Paste -> Update CtrlVState PasteId insertPaste p@Paste{..} | pasteId pasteMeta == PasteId 0 = do cvs@CtrlVState{..} <- get put $ cvs { pastes = IxSet.insert (p { pasteMeta = pasteMeta { pasteId = nextPasteId }}) pastes , nextPasteId = succ nextPasteId } return nextPasteId | otherwise = do cvs@CtrlVState{..} <- get put $ cvs { pastes = IxSet.updateIx (pasteId pasteMeta) p pastes } return (pasteId pasteMeta) -- | get a paste by it's 'PasteId' getPasteById :: PasteId -> Query CtrlVState (Maybe Paste) getPasteById pid = getOne . getEQ pid . pastes <$> ask type Limit = Int type Offset = Int -- | get recent pastes getRecentPastes :: Limit -- ^ maximum number of recent pastes to return -> Offset -- ^ number of pastes skip (useful for pagination) -> Query CtrlVState [PasteMeta] getRecentPastes limit offset = do CtrlVState{..} <- ask return $ map pasteMeta $ take limit $ drop offset $ IxSet.toDescList (Proxy :: Proxy UTCTime) pastes -- | now we need to tell acid-state which functions should be turn into -- acid-state events. $(makeAcidic ''CtrlVState [ 'getPasteById , 'getRecentPastes , 'insertPaste ]) ------------------------------------------------------------------------------ -- Route ------------------------------------------------------------------------------ -- | All the routes for our web application data Route = ViewRecent | ViewPaste PasteId | NewPaste | CSS deriving (Eq, Ord, Read, Show, Data, Typeable) -- | we will just use template haskell to derive the route mapping $(derivePathInfo ''Route) ------------------------------------------------------------------------------ -- CtrlV type-aliases ------------------------------------------------------------------------------ -- | The foundation types are heavily parameterized -- but for our app -- we can pin all the type parameters down. type CtrlV' = FoundationT' Route CtrlVState () IO type CtrlV = XMLGenT CtrlV' type CtrlVForm = FoundationForm Route CtrlVState () IO ------------------------------------------------------------------------------ -- appTemplate ------------------------------------------------------------------------------ -- | page template function appTemplate :: ( EmbedAsChild CtrlV' headers , EmbedAsChild CtrlV' body ) => Lazy.Text -- ^ page title -> headers -- ^ extra headers to add to \
tag -> body -- ^ contents of \ tag -> CtrlV Response appTemplate ttl moreHdrs bdy = do html <- defaultTemplate ttl <%><% moreHdrs %>%> $ <%>There are no pastes yet.
_ -> appTemplate "Recent Pastes" () $ <%>id | title | author | date | format |
---|
Paste <% pid %> could not be found.
(Just (Paste (PasteMeta{..}) paste)) -> do ok () appTemplate (Lazy.pack $ "Paste " ++ (show $ unPasteId pid)) () $<% txt %>-- | page handler for 'NewPaste' newPastePage :: CtrlV Response newPastePage = do here <- whereami appTemplate "Add a Paste" () $ <%>