{-# LANGUAGE DeriveDataTypeable, FlexibleContexts, FlexibleInstances, GeneralizedNewtypeDeriving, MultiParamTypeClasses, OverloadedStrings, RecordWildCards, TemplateHaskell, TypeFamilies, TypeSynonymInstances, OverloadedStrings #-} {-# OPTIONS_GHC -F -pgmFhsx2hs #-} module Main where import Happstack.Foundation import Control.Exception (bracket) import Data.Acid.Local (createCheckpointAndClose) import qualified Data.IxSet as IxSet import Data.IxSet (IxSet, Indexable, Proxy(..), (@=), getEQ, getOne, ixSet, ixFun) import Data.Maybe (fromMaybe) import Data.Text (Text) import qualified Data.Text.Lazy as Lazy import qualified Data.Text as Text import Data.Time.Clock (UTCTime, getCurrentTime) import System.FilePath ((>)) ------------------------------------------------------------------------------ -- 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) $(deriveSafeCopy 0 'base ''PasteId) $(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 Acid () IO type CtrlV = XMLGenT CtrlV' type CtrlVForm = FoundationForm Route Acid () IO ------------------------------------------------------------------------------ -- From demo-hsp Acid.hs ------------------------------------------------------------------------------ -- | 'Acid' holds all the 'AcidState' handles for this site. data Acid = Acid { acidPaste :: AcidState CtrlVState } instance (Functor m, Monad m) => HasAcidState (FoundationT' url Acid reqSt m) CtrlVState where getAcidState = acidPaste <$> getAcidSt -- | run an action which takes 'Acid'. -- -- Uses 'bracket' to open / initialize / close all the 'AcidState' handles. -- -- WARNING: The database files should only be opened by one thread in -- one application at a time. If you want to access the database from -- multiple threads (which you almost certainly do), then simply pass -- the 'Acid' handle to each thread. withAcid :: Maybe FilePath -- ^ state directory -> (Acid -> IO a) -- ^ action -> IO a withAcid mBasePath f = let basePath = fromMaybe "_state" mBasePath in bracket (openLocalStateFrom (basePath > "paste") initialCtrlVState) (createCheckpointAndClose) $ \paste -> f (Acid paste) ------------------------------------------------------------------------------ -- 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" () $ <%>