Last active
August 29, 2015 14:04
-
-
Save joefiorini/df6813cdf6ac560c1ede to your computer and use it in GitHub Desktop.
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
main.hs:136:7: | |
Couldn't match expected type `Data.Text.Internal.Lazy.Text' | |
with actual type `StringType m1' | |
The type variable `m1' is ambiguous | |
Possible fix: add a type signature that fixes these type variable(s) | |
In the second argument of `($)', namely | |
`template | |
"Home" | |
() | |
(genElement | |
(Nothing, fromStringLit "div") | |
[] | |
[asChild | |
((genElement | |
(Nothing, fromStringLit "h1") | |
[] | |
[asChild (fromStringLit "Welcome to the Happstack CMS!")])), | |
asChild | |
((genElement | |
(Nothing, fromStringLit "p") | |
[] | |
[asChild | |
(fromStringLit | |
"This is a demo CMS written in Happstack. Cool stuff, eh?")])), | |
asChild | |
((genElement | |
(Nothing, fromStringLit "a") | |
[asAttr (fromStringLit "href" := fromStringLit "/announcements")] | |
[asChild (fromStringLit "Announcements")]))])' | |
In the expression: | |
ok <$> toResponse | |
$ template | |
"Home" | |
() | |
(genElement | |
(Nothing, fromStringLit "div") | |
[] | |
[asChild | |
((genElement | |
(Nothing, fromStringLit "h1") | |
[] | |
[asChild (fromStringLit "Welcome to the Happstack CMS!")])), | |
asChild | |
((genElement | |
(Nothing, fromStringLit "p") | |
[] | |
[asChild | |
(fromStringLit | |
"This is a demo CMS written in Happstack. Cool stuff, eh?")])), | |
asChild | |
((genElement | |
(Nothing, fromStringLit "a") | |
[asAttr (fromStringLit "href" := fromStringLit "/announcements")] | |
[asChild (fromStringLit "Announcements")]))]) | |
In an equation for `homePage': | |
homePage | |
= ok <$> toResponse | |
$ template | |
"Home" | |
() | |
(genElement | |
(Nothing, fromStringLit "div") | |
[] | |
[asChild | |
((genElement | |
(Nothing, fromStringLit "h1") | |
[] | |
[asChild (fromStringLit "Welcome to the Happstack CMS!")])), | |
asChild | |
((genElement | |
(Nothing, fromStringLit "p") | |
[] | |
[asChild | |
(fromStringLit | |
"This is a demo CMS written in Happstack. Cool stuff, eh?")])), | |
asChild | |
((genElement | |
(Nothing, fromStringLit "a") | |
[asAttr (fromStringLit "href" := fromStringLit "/announcements")] | |
[asChild (fromStringLit "Announcements")]))]) | |
main.hs:148:20: | |
Couldn't match expected type `Data.Text.Internal.Lazy.Text' | |
with actual type `StringType m0' | |
The type variable `m0' is ambiguous | |
Possible fix: add a type signature that fixes these type variable(s) | |
In the expression: | |
defaultTemplate | |
"Announcements" | |
() | |
(genElement | |
(Nothing, fromStringLit "div") | |
[] | |
[asChild | |
((genElement | |
(Nothing, fromStringLit "p") | |
[] | |
[asChild | |
(fromStringLit "\"There are no announcements in the system\"")])), | |
asChild | |
((genElement | |
(Nothing, fromStringLit "form") | |
[asAttr (fromStringLit "method" := fromStringLit "post"), | |
asAttr (fromStringLit "action" := fromStringLit "/new")] | |
[asChild | |
((genElement (Nothing, fromStringLit "button") [...] [...]))]))]) | |
In a case alternative: | |
[] | |
-> defaultTemplate | |
"Announcements" | |
() | |
(genElement | |
(Nothing, fromStringLit "div") | |
[] | |
[asChild | |
((genElement | |
(Nothing, fromStringLit "p") | |
[] | |
[asChild | |
(fromStringLit "\"There are no announcements in the system\"")])), | |
asChild | |
((genElement | |
(Nothing, fromStringLit "form") | |
[asAttr (fromStringLit "method" := fromStringLit "post"), ....] | |
[asChild ((genElement ... ... ...))]))]) | |
In the second argument of `($)', namely | |
`case announcements of { | |
[] | |
-> defaultTemplate | |
"Announcements" | |
() | |
(genElement | |
(Nothing, fromStringLit "div") | |
[] | |
[asChild ((genElement (Nothing, fromStringLit "p") [] [...])), | |
asChild | |
((genElement (Nothing, fromStringLit "form") [...] [...]))]) | |
_ -> defaultTemplate | |
"Announcements" | |
() | |
(genElement (Nothing, fromStringLit "div") [] []) }' |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
{-# LANGUAGE CPP, DeriveDataTypeable, FlexibleContexts, | |
GeneralizedNewtypeDeriving, MultiParamTypeClasses, | |
TemplateHaskell, TypeFamilies, RecordWildCards, | |
OverloadedStrings, ScopedTypeVariables, OverlappingInstances, NoMonomorphismRestriction #-} | |
{-# OPTIONS_GHC -F -pgmFhsx2hs #-} | |
module Main where | |
import Control.Applicative ((<$>), optional) | |
import Control.Monad (msum) | |
import Control.Monad.IO.Class (liftIO) | |
import Control.Monad.Reader (ask) | |
import Control.Monad.State (get, put) | |
import Data.Maybe (fromMaybe) | |
import Data.Text (Text) | |
import Data.Text as DText | |
import Data.Text (unpack) | |
import Data.Data (Data, Typeable) | |
import Data.IxSet as IxSet | |
import Happstack.Server | |
( Happstack, HasRqData, Method(GET, POST), Request(rqMethod) | |
, Response | |
, ServerPartT(..), ServerPart, WebMonad, FilterMonad, ServerMonad | |
, askRq, decodeBody, dir, defaultBodyPolicy, lookText | |
, mapServerPartT, nullConf, nullDir, ok, simpleHTTP | |
, seeOther, method | |
, toResponse | |
) | |
import Control.Exception (bracket) | |
import Data.Monoid | |
import HSP | |
import HSP.Monad | |
import Happstack.Server.HSP.HTML | |
import Happstack.Server.XMLGenT | |
import HSP.HTML4 | |
import Data.Time (UTCTime) | |
import Data.Time.Clock (getCurrentTime) | |
import Data.Acid (AcidState, Query, Update, makeAcidic, openLocalState) | |
import Data.Acid.Advanced (query', update') | |
import Data.Acid.Local (createCheckpointAndClose) | |
import Data.SafeCopy (base, deriveSafeCopy, SafeCopy) | |
newtype ContentItemId = ContentItemId { itemId' :: Integer } | |
deriving (Eq, Ord, Data, Show, Enum, Read, Typeable, SafeCopy) | |
newtype ContentItemSlug = ContentItemSlug { itemSlug :: String } | |
deriving (Eq, Ord, Data, Show, Read, Typeable, SafeCopy) | |
data ContentItemType = Announcement | Event | Offer | |
deriving (Eq, Ord, Show, Data, Read, Typeable) | |
$(deriveSafeCopy 0 'base ''ContentItemType) | |
data ContentItem = ContentItem { | |
itemId :: ContentItemId, | |
itemType :: ContentItemType, | |
title :: Text, | |
description :: Text, | |
slug :: Maybe ContentItemSlug, | |
publishAt :: UTCTime, | |
createdAt :: UTCTime, | |
updatedAt :: UTCTime | |
} deriving (Eq, Ord, Read, Show, Data, Typeable) | |
$(deriveSafeCopy 0 'base ''ContentItem) | |
{- Need to also index by itemType, so I can query by itemType in the UI -} | |
instance Indexable ContentItem where | |
empty = ixSet | |
[ ixFun $ \item -> [ itemId item ], | |
ixFun $ \item -> [ slug item ], | |
ixFun $ \item -> [ itemType item ] | |
] | |
data ContentCollection = ContentCollection { | |
nextContentItemId :: ContentItemId, | |
contentItems :: IxSet ContentItem | |
} deriving (Data, Typeable) | |
$(deriveSafeCopy 0 'base ''ContentCollection) | |
initialContentState :: ContentCollection | |
initialContentState = | |
ContentCollection { nextContentItemId = ContentItemId 1, | |
contentItems = IxSet.empty | |
} | |
newContentItem :: UTCTime -> Update ContentCollection ContentItem | |
newContentItem pubDate = do | |
c@ContentCollection{..} <- get | |
let contentItem = ContentItem { itemId = nextContentItemId, | |
title = DText.empty, | |
description = DText.empty, | |
slug = Nothing, | |
publishAt = pubDate, | |
itemType = Announcement, | |
createdAt = pubDate, | |
updatedAt = pubDate } | |
put $ c { nextContentItemId = succ nextContentItemId, | |
contentItems = IxSet.insert contentItem contentItems } | |
return contentItem | |
allAnnouncements :: Query ContentCollection [ContentItem] | |
allAnnouncements = do | |
ContentCollection{..} <- ask | |
let items' = IxSet.toList $ contentItems @= Announcement | |
return items' | |
$(makeAcidic ''ContentCollection | |
[ 'newContentItem | |
, 'allAnnouncements | |
]) | |
main :: IO () | |
main = do bracket (openLocalState initialContentState) | |
(createCheckpointAndClose) | |
(\acid -> | |
simpleHTTP nullConf (myApp acid)) | |
myApp :: AcidState ContentCollection -> ServerPart Response | |
myApp acid = msum | |
[ dir "announcements" $ announcements acid, | |
dir "new" $ newAnnouncement acid, | |
homePage ] | |
template = defaultTemplate | |
homePage :: ServerPart Response | |
homePage = | |
ok <$> toResponse $ template "Home" | |
() | |
<div> | |
<h1>Welcome to the Happstack CMS!</h1> | |
<p>This is a demo CMS written in Happstack. Cool stuff, eh?</p> | |
<a href="/announcements">Announcements</a> | |
</div> | |
announcements :: AcidState ContentCollection -> ServerPart Response | |
announcements acid = do | |
announcements <- query' acid (AllAnnouncements) | |
ok <$> toResponse $ | |
case announcements of | |
[] -> defaultTemplate "Announcements" | |
() | |
<div> | |
<p>"There are no announcements in the system"</p> | |
<form method="post" action="/new"> | |
<button type="submit">New Announcement</button> | |
</form> | |
</div> | |
_ -> defaultTemplate "Announcements" () <div></div> | |
-- H.ol $ mapM_ announcement' announcements | |
-- where | |
-- announcement' ContentItem{..} = | |
-- H.h3 (H.toHtml $ show title) | |
newAnnouncement :: AcidState ContentCollection -> ServerPart Response | |
newAnnouncement acid = do | |
method POST | |
now <- liftIO $ getCurrentTime | |
item <- update' acid (NewContentItem now) | |
let url = "/edit?id=" ++ show (itemId' $ itemId item) | |
seeOther url (toResponse ()) |
stepcut
commented
Jul 23, 2014
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment