Created
April 15, 2016 22:32
-
-
Save justindthomas/b9948090d1fdf1f3887a5f95d147bd6c 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
| {-# LANGUAGE FlexibleContexts #-} | |
| {-# LANGUAGE GADTs #-} | |
| {-# LANGUAGE GeneralizedNewtypeDeriving #-} | |
| {-# LANGUAGE MultiParamTypeClasses #-} | |
| {-# LANGUAGE OverloadedStrings #-} | |
| {-# LANGUAGE DeriveGeneric #-} | |
| {-# LANGUAGE QuasiQuotes #-} | |
| {-# LANGUAGE TemplateHaskell #-} | |
| {-# LANGUAGE TypeFamilies #-} | |
| module Main where | |
| import Web.Scotty | |
| import Database.Persist ((==.), (=.)) | |
| import qualified Database.Persist as DB | |
| import qualified Database.Persist.Postgresql as DB | |
| import Database.Persist.TH | |
| import Data.Aeson | |
| import GHC.Generics | |
| import Control.Monad.IO.Class (MonadIO,liftIO) | |
| import Control.Monad.Trans.Class (MonadTrans, lift) | |
| import Control.Monad.Logger (runStderrLoggingT) | |
| import Data.Monoid ((<>)) | |
| import qualified Data.Text.Lazy as T | |
| import qualified Data.Text.Internal as I | |
| import qualified Data.List as L | |
| import Data.Maybe | |
| import Text.Pandoc | |
| import Text.Pandoc.Error | |
| import Data.Text.Encoding (encodeUtf8) | |
| import System.IO | |
| share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistLowerCase| | |
| Article | |
| json | |
| title String | |
| content String | |
| deriving Show | |
| deriving Generic | |
| |] | |
| connStr :: DB.ConnectionString | |
| connStr = "host=hostname dbname=db user=username port=5432 sslkey=key sslcert=cert" | |
| markdownToHtml :: String -> T.Text | |
| markdownToHtml = pandocToHtml . markdownToPandoc | |
| markdownToPandoc :: String -> Pandoc | |
| markdownToPandoc = handleError . readMarkdown def | |
| pandocToHtml :: Pandoc -> T.Text | |
| pandocToHtml = T.pack . writeHtmlString def | |
| readDbConfig :: IO String | |
| readDbConfig = do | |
| c <- readFile "db.conf" | |
| return $ T.unpack $ buildString $ T.lines $ T.pack c | |
| buildString :: [T.Text] -> T.Text | |
| buildString = T.unwords | |
| main :: IO () | |
| main = do | |
| putStrLn "Starting Server..." | |
| scotty 3000 $ do | |
| get "/" $ html "Hello World!" | |
| get "/articles" $ do | |
| articles <- inHandlerDb $ DB.selectList [] [] | |
| html ("Articles!" <> (T.pack $ show $ length (articles :: [DB.Entity Article]))) | |
| get "/articles/:id" $ do | |
| articleId <- param "id" | |
| findArticle <- inHandlerDb $ DB.get (DB.toSqlKey (read articleId)) | |
| html $ (markdownToHtml $ articleContent (fromMaybe (Article "Invalid Entry" "No such article exists.") (findArticle :: Maybe Article))) | |
| get "/articles/:id/raw" $ do | |
| articleId <- param "id" | |
| findArticle <- inHandlerDb $ DB.get (DB.toSqlKey (read articleId)) | |
| html $ (T.pack $ articleContent (fromMaybe (Article "Invalid Entry" "No such article exists.") (findArticle :: Maybe Article))) | |
| put "/articles/:id" $ do | |
| article <- jsonData | |
| articleId <- param "id" | |
| inHandlerDb $ do | |
| DB.replace (DB.toSqlKey (read articleId)) $ (article :: Article) | |
| text (T.pack $ "updated") | |
| put "/articles/:id/content" $ do | |
| article <- body | |
| articleId <- param "id" | |
| inHandlerDb $ do | |
| DB.update (DB.toSqlKey (read articleId)) [ArticleContent =. (show article)] | |
| text (T.pack $ "updated") | |
| post "/articles" $ do | |
| article <- jsonData | |
| articleId <- inHandlerDb $ DB.insert (article :: Article) | |
| text (T.pack $ "inserted: " <> show articleId) | |
| delete "/articles/:id" $ do | |
| articleId <- param "id" | |
| inHandlerDb $ DB.deleteWhere [ArticleId ==. (DB.toSqlKey (read articleId))] | |
| text (T.pack $ "deleted: " <> show articleId) | |
| instance FromJSON Article | |
| deleteArticle articleId = do | |
| inHandlerDb $ DB.deleteWhere [ArticleId ==. (DB.toSqlKey articleId)] | |
| return (T.pack $ "deleted: " <> show articleId) | |
| inHandlerDb = liftIO . dbFunction | |
| dbFunction query = runStderrLoggingT $ | |
| DB.withPostgresqlPool connStr 10 $ | |
| \pool -> liftIO $ DB.runSqlPersistMPool query pool | |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment