Created
January 5, 2016 01:25
-
-
Save hhefesto/9af2f7f2ead601b5ec84 to your computer and use it in GitHub Desktop.
using yesod's persistent.
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 EmptyDataDecls #-} | |
{-# LANGUAGE FlexibleContexts #-} | |
{-# LANGUAGE GADTs #-} | |
{-# LANGUAGE GeneralizedNewtypeDeriving #-} | |
{-# LANGUAGE MultiParamTypeClasses #-} | |
{-# LANGUAGE OverloadedStrings #-} | |
{-# LANGUAGE QuasiQuotes #-} | |
{-# LANGUAGE TemplateHaskell #-} | |
{-# LANGUAGE TypeFamilies #-} | |
module Model where | |
import Control.Monad.IO.Class (liftIO) | |
import Control.Monad.Logger (runStderrLoggingT) | |
import Database.Persist | |
import Database.Persist.Postgresql | |
import Database.Persist.TH | |
import Data.Time | |
import Data.Int | |
share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistLowerCase| | |
User | |
email String | |
alias String | |
image_url String | |
show_email Bool | |
UniqueEmail email | |
date UTCTime default=CURRENT_TIME | |
deriving Show | |
Post | |
atom Int | |
material String | |
processing String | |
params String | |
image_url String | |
reference String | |
owner UserId | |
material_url String | |
date UTCTime default=CURRENT_TIME | |
deriving Show | |
|] | |
connStr = "host=localhost dbname=communis-db user=communis password=develPassword port=5432" | |
new_user :: User -> IO () | |
new_user(User email alias image_url show_email _) = runStderrLoggingT $ withPostgresqlPool connStr 10 $ \pool -> liftIO $ do | |
flip runSqlPersistMPool pool $ do | |
runMigration migrateAll | |
now <- liftIO getCurrentTime | |
usrid <- insert $ User email alias image_url show_email now | |
usr <- get usrid | |
liftIO $ print usr | |
update_user :: String -> User -> IO() | |
update_user em u = runStderrLoggingT $ withPostgresqlPool connStr 10 $ \pool -> liftIO $ do | |
flip runSqlPersistMPool pool $ do | |
runMigration migrateAll | |
usr <- getBy $ UniqueEmail em | |
case usr of | |
Just (Entity userId user) -> replace userId user | |
{- | |
delete_user :: Int64 -> IO () | |
delete_user i = runStderrLoggingT $ withPostgresqlPool connStr 10 $ \pool -> liftIO $ do | |
flip runSqlPersistMPool pool $ do | |
runMigration migrateAll | |
delete (toSqlKey i) | |
-} | |
new_post :: Post -> IO () | |
new_post (Post atom material processing params image_url reference owner material_url _) = runStderrLoggingT $ withPostgresqlPool connStr 10 $ \pool -> liftIO $ do | |
flip runSqlPersistMPool pool $ do | |
runMigration migrateAll | |
now <- liftIO getCurrentTime | |
postId <- insert $ Post atom material processing params image_url reference owner material_url now | |
post <- get postId | |
liftIO $ print post | |
update_post :: Int64 -> Post -> IO() | |
update_post id post = runStderrLoggingT $ withPostgresqlPool connStr 10 $ \pool -> liftIO $ do | |
flip runSqlPersistMPool pool $ do | |
runMigration migrateAll | |
replace (toSqlKey id) post | |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment