Permalink
Fetching contributors…
Cannot retrieve contributors at this time
59 lines (51 sloc) 2.17 KB
{-# LANGUAGE QuasiQuotes, TypeFamilies, GeneralizedNewtypeDeriving, TemplateHaskell, OverloadedStrings, TypeSynonymInstances, GADTs, FlexibleInstances, MultiParamTypeClasses #-}
module Model where
import Yesod.Persist
import Database.Persist.Base (DeleteCascade (..))
import Yesod.Content (HasReps (..), toContent)
import Data.Text (Text, pack)
import Data.Time (UTCTime)
import Text.Hamlet (Html)
import Yesod.Form (Textarea)
import Yesod.Core (SinglePiece (..), MultiPiece (..))
import Data.ByteString (ByteString)
import Data.ByteString.Base64 (decodeLenient)
data TopicFormat = TFMarkdown | TFHtml | TFText | TFDitaConcept | TFDitaTopic
deriving (Read, Eq, Show)
derivePersistField "TopicFormat"
newtype MapNodeSlug = MapNodeSlug { unMapNodeSlug :: Text }
deriving (Read, Eq, Show, PersistField, SinglePiece, Ord)
type MapNodeSlugs = [MapNodeSlug]
instance MultiPiece MapNodeSlugs where
toMultiPiece = map unMapNodeSlug
fromMultiPiece = fmap (map MapNodeSlug) . fromMultiPiece
newtype BlogSlugT = BlogSlugT Text
deriving (Read, Eq, Show, PersistField, SinglePiece, Ord)
newtype UserHandleT = UserHandleT { unUserHandle :: Text }
deriving (Read, Eq, Show, PersistField, SinglePiece, Ord)
newtype Month = Month Int
deriving (Read, Eq, Show, PersistField, Ord)
instance SinglePiece Month where
toSinglePiece (Month i)
| i < 10 && i >= 0 = pack $ '0' : show i
| otherwise = toSinglePiece i
fromSinglePiece t = do
i <- fromSinglePiece t
if i >= 1 && i <= 12
then Just $ Month i
else Nothing
formats :: [(Text, TopicFormat)]
formats =
[ ("Markdown", TFMarkdown)
, ("HTML", TFHtml)
, ("Plain text", TFText)
, ("DITA Concept", TFDitaConcept)
, ("DITA Topic", TFDitaTopic)
]
-- You can define all of your database entities in the entities file.
-- You can find more information on persistent and how to declare entities
-- at:
-- http://www.yesodweb.com/book/persistent/
share [mkPersist sqlSettings, mkMigrate "migrateAll", mkDeleteCascade] $(persistFile "config/models")
instance HasReps StaticContent where
chooseRep (StaticContent mt content) _ = return (mt, toContent $ decodeLenient content)