73 lines
1.8 KiB
Haskell
73 lines
1.8 KiB
Haskell
{-# LANGUAGE EmptyDataDecls #-}
|
|
{-# LANGUAGE FlexibleContexts #-}
|
|
{-# LANGUAGE GADTs #-}
|
|
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
|
{-# LANGUAGE MultiParamTypeClasses #-}
|
|
{-# LANGUAGE OverloadedStrings #-}
|
|
{-# LANGUAGE QuasiQuotes #-}
|
|
{-# LANGUAGE TemplateHaskell #-}
|
|
{-# LANGUAGE TypeFamilies #-}
|
|
{-# LANGUAGE DeriveGeneric #-}
|
|
{-# LANGUAGE FlexibleInstances #-}
|
|
{-# LANGUAGE RecordWildCards #-}
|
|
|
|
module Model where
|
|
|
|
import GHC.Generics
|
|
import Database.Persist
|
|
import Database.Persist.Sql
|
|
import Database.Persist.TH
|
|
import Data.Text (Text(..))
|
|
import Data.Aeson
|
|
|
|
import PasteType
|
|
|
|
share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistLowerCase|
|
|
User json
|
|
username Text
|
|
password Text
|
|
Username username
|
|
deriving Show Generic Eq
|
|
|
|
Paste json
|
|
poster UserId
|
|
name Text
|
|
content Text
|
|
type PasteType
|
|
PasteNamePoster name poster
|
|
deriving Show Generic Eq
|
|
|]
|
|
|
|
data SanitizedPaste = SanitizedPaste
|
|
{ name :: Text
|
|
, content :: Text
|
|
, type_ :: PasteType
|
|
} deriving (Show, Generic, Eq)
|
|
|
|
-- Make the API slightly nicer by not having an ugly underscore on type_
|
|
instance ToJSON SanitizedPaste where
|
|
toJSON (SanitizedPaste name content type_) = object ["name" .= name, "content" .= content, "type" .= type_]
|
|
|
|
instance FromJSON SanitizedPaste where
|
|
parseJSON = withObject "SanitizedPaste" $ \v -> SanitizedPaste
|
|
<$> v .: "name"
|
|
<*> v .: "content"
|
|
<*> v .: "type"
|
|
|
|
sanitizePaste :: Paste -> SanitizedPaste
|
|
sanitizePaste Paste{..} = SanitizedPaste
|
|
{ name = pasteName
|
|
, content = pasteContent
|
|
, type_ = pasteType
|
|
}
|
|
|
|
attachPoster :: Key User -> SanitizedPaste -> Paste
|
|
attachPoster uid SanitizedPaste{..} = Paste
|
|
{ pasteName = name
|
|
, pasteContent = content
|
|
, pasteType = type_
|
|
, pastePoster = uid
|
|
}
|
|
|
|
doMigrations :: SqlPersistT IO ()
|
|
doMigrations = runMigration migrateAll |