Permalink
Browse files

First commit.

  • Loading branch information...
0 parents commit 4e5d21be3d9368decdb4b8a8f1e929eae9aa4c08 @chrisdone committed Jun 4, 2011
@@ -0,0 +1,6 @@
+cabal-dev
+dist
+log
+src/TAGS
+*.hi
+*.o
@@ -0,0 +1,2 @@
+import Distribution.Simple
+main = defaultMain
@@ -0,0 +1,30 @@
+Name: amelie
+Version: 0.1
+Synopsis: Haskell paste web site.
+Description: Haskell paste web site.
+Homepage: http://hpaste.org/
+License: GPL
+Author: Chris Done <chrisdone@gmail.com>
+Maintainer: Chris Done <chrisdone@gmail.com>
+Copyright: 2011 by Chris Done
+Category: Web
+Build-type: Simple
+Cabal-version: >=1.2
+
+Executable amelie
+ Main-is: Main.hs
+ Ghc-options: -threaded -O2
+ Hs-source-dirs: src
+ Build-depends: base >= 4 && < 5
+ ,snap-server >= 0.4 && < 0.5
+ ,snap-core >= 0.4 && < 0.5
+ ,text >= 0.11 && < 0.12
+ ,blaze-html >= 0.4 && < 0.5
+ ,bytestring >= 0.9 && < 0.10
+ ,containers >= 0.3 && < 0.4
+ ,mtl >= 2.0 && < 2.1
+ ,transformers >= 0.2 && < 0.3
+ ,utf8-string >= 0.3 && < 0.4
+ ,pgsql-simple >= 0.0.2
+ ,network >= 2.3 && < 2.4
+ ,MonadCatchIO-transformers >= 0.2 && < 0.3
@@ -0,0 +1,8 @@
+#! /bin/bash
+
+mkdir log -p
+echo 'Killing ...'
+killall amelie
+sleep 1
+echo 'Starting ...'
+dist/build/amelie/amelie & disown
@@ -0,0 +1,34 @@
+{-# OPTIONS -Wall #-}
+
+-- | Controller routing/handling.
+
+module Amelie.Controller
+ (runHandler
+ ,output)
+ where
+
+import Amelie.Types
+import Amelie.Model.Config (auth)
+
+import Control.Monad.IO
+import Control.Monad.Reader (runReaderT)
+import Data.Text.Lazy (toStrict)
+import Database.PostgreSQL.Simple (connect)
+import Snap.Types (Snap,writeText)
+import Text.Blaze (Html)
+import Text.Blaze.Renderer.Text (renderHtml)
+
+-- | Run a controller handler.
+runHandler :: Controller () -> Snap ()
+runHandler ctrl = do
+ conn <- io $ connect auth
+ let state = ControllerState conn
+ runReaderT (runController ctrl) state
+
+-- | Strictly renders HTML to Text before outputting it via Snap.
+-- This ensures that any lazy exceptions are caught by the Snap
+-- handler.
+output :: Html -> Controller ()
+output html = do
+ let !x = toStrict $ renderHtml $ html
+ writeText $ x
@@ -0,0 +1,18 @@
+{-# OPTIONS -Wall #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+-- | Home page controller.
+
+module Amelie.Controller.Home
+ (handle)
+ where
+
+import Amelie.Controller (output)
+import Amelie.Model
+import Amelie.Model.Home (getPastes)
+import Amelie.View.Home (page)
+
+handle :: Controller ()
+handle = do
+ pastes <- model $ getPastes
+ output $ page pastes
@@ -0,0 +1,37 @@
+{-# OPTIONS -Wall #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+-- | Model running.
+
+module Amelie.Model
+ (model
+ ,query
+ ,queryNoParams
+ ,module Amelie.Types)
+ where
+
+import Amelie.Types
+
+import Control.Monad.Env
+import Control.Monad.IO
+import Control.Monad.Reader
+import Data.String
+import qualified Database.PostgreSQL.Simple as DB
+import Database.PostgreSQL.Simple.QueryParams
+import Database.PostgreSQL.Simple.QueryResults
+
+model :: Model a -> Controller a
+model action = do
+ conn <- env controllerStateConn
+ let state = ModelState conn
+ io $ runReaderT (runModel action) state
+
+query :: (QueryParams ps,QueryResults r) => [String] -> ps -> Model [r]
+query q ps = do
+ conn <- env modelStateConn
+ Model $ ReaderT (\_ -> DB.query conn (fromString (unlines q)) ps)
+
+queryNoParams :: (QueryResults r) => [String] -> Model [r]
+queryNoParams q = do
+ conn <- env modelStateConn
+ Model $ ReaderT (\_ -> DB.query_ conn (fromString (unlines q)))
@@ -0,0 +1,17 @@
+{-# OPTIONS -Wall #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+-- | Database configuration.
+
+module Amelie.Model.Config where
+
+import Database.PostgreSQL.Simple
+
+-- | Postgres connection information.
+auth :: ConnectInfo
+auth = ConnectInfo { connectHost = "127.0.0.1"
+ , connectPort = 5432
+ , connectUser = "amelie"
+ , connectPassword = "amelie"
+ , connectDatabase = "amelie"
+ }
@@ -0,0 +1,14 @@
+{-# OPTIONS -Wall #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+-- | Home page model.
+
+module Amelie.Model.Home
+ (getPastes)
+ where
+
+import Amelie.Model
+import Amelie.Model.Paste
+
+getPastes :: Model [Paste]
+getPastes = getLatestPastes
@@ -0,0 +1,17 @@
+{-# OPTIONS -Wall #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+-- | Paste model.
+
+module Amelie.Model.Paste
+ (getLatestPastes)
+ where
+
+import Amelie.Types
+import Amelie.Model
+
+getLatestPastes :: Model [Paste]
+getLatestPastes = queryNoParams ["SELECT title,author,language,channel,content"
+ ,"FROM toplevel_paste"
+ ,"ORDER BY id DESC"
+ ,"LIMIT 10"]
@@ -0,0 +1,13 @@
+{-# OPTIONS -Wall #-}
+
+-- | All types.
+
+module Amelie.Types
+ (module Amelie.Types.MVC
+ ,module Amelie.Types.Paste
+ ,module Amelie.Types.Page)
+ where
+
+import Amelie.Types.MVC
+import Amelie.Types.Paste
+import Amelie.Types.Page
@@ -0,0 +1,48 @@
+{-# OPTIONS -Wall #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+
+-- | Model-view-controller types.
+
+module Amelie.Types.MVC
+ (Controller(..)
+ ,Model(..)
+ ,ControllerState(..)
+ ,ModelState(..))
+ where
+
+import Control.Applicative (Applicative,Alternative)
+import Control.Monad (MonadPlus)
+import Control.Monad.Catch (MonadCatchIO)
+import Control.Monad.Reader (ReaderT,MonadReader)
+import Control.Monad.Trans (MonadIO)
+import Database.PostgreSQL.Simple (Connection)
+import Snap.Types (Snap,MonadSnap)
+
+-- | The state accessible to the controller (DB/session stuff).
+data ControllerState = ControllerState {
+ controllerStateConn :: Connection
+ }
+
+-- | The controller monad.
+newtype Controller a = Controller {
+ runController :: ReaderT ControllerState Snap a
+ } deriving (Monad
+ ,Functor
+ ,Applicative
+ ,Alternative
+ ,MonadReader ControllerState
+ ,MonadSnap
+ ,MonadIO
+ ,MonadPlus
+ ,MonadCatchIO)
+
+-- | The state accessible to the model (just DB connection).
+data ModelState = ModelState {
+ modelStateConn :: Connection
+ }
+
+-- | The model monad (limited access to IO, only DB access).
+newtype Model a = Model {
+ runModel :: ReaderT ModelState IO a
+ } deriving (Monad,Functor,Applicative,MonadReader ModelState)
@@ -0,0 +1,17 @@
+{-# OPTIONS -Wall #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+-- | The page type.
+
+module Amelie.Types.Page
+ (Page(..))
+ where
+
+import Data.Text (Text)
+import Text.Blaze (Html)
+
+-- | A page to be rendered in a layout.
+data Page = Page {
+ pageTitle :: Text
+ , pageBody :: Html
+ }
@@ -0,0 +1,36 @@
+{-# OPTIONS -Wall #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+-- | The paste type.
+
+module Amelie.Types.Paste
+ (Paste(..))
+ where
+
+import Data.Text (Text,pack)
+import Database.PostgreSQL.Simple.QueryResults (QueryResults(..))
+import Text.Blaze (ToHtml(..),toHtml)
+
+-- | A paste.
+data Paste = Paste {
+ pasteTitle :: Text
+ ,pasteAuthor :: Text
+ ,pasteLanguage :: Maybe Text
+ ,pasteChannel :: Maybe Text
+ ,pastePaste :: Text
+} deriving Show
+
+instance ToHtml Paste where
+ toHtml paste@Paste{..} = toHtml $ pack $ show paste
+
+instance QueryResults Paste where
+ convertResults field values = Paste {
+ pasteTitle = title
+ , pasteAuthor = author
+ , pasteLanguage = language
+ , pasteChannel = channel
+ , pastePaste = paste
+ }
+ where (title,author,language,channel,paste) = convertResults field values
@@ -0,0 +1,38 @@
+{-# OPTIONS -Wall #-}
+{-# LANGUAGE OverloadedStrings, RecordWildCards, FlexibleInstances #-}
+{-# LANGUAGE TupleSections #-}
+{-# OPTIONS -fno-warn-name-shadowing #-}
+
+-- | Forms used throughout.
+
+module Amelie.View.Forms where
+
+import Amelie.Types
+
+import Control.Applicative
+import Control.Monad.Error
+import Data.Either.Extra
+import Data.Maybe
+import Prelude hiding ((++))
+import Snap.Types
+import Text.Blaze.Html5 as H
+import qualified Text.Blaze.Html5.Attributes as A
+import Text.Blaze.Html5.Extra
+import Text.Formlet
+
+pasteForm :: Snap (Html,Maybe Paste)
+pasteForm = do
+ params <- getParams
+ let value = formletValue formlet params
+ submitted <- isJust <$> getParam "submit"
+ let form = postForm $ do
+ formletHtml formlet params
+ submitInput "submit" "Submit"
+ when submitted $ whenLeft value (mapM_ (p . toHtml))
+ return (form,either (const Nothing) Just $ value)
+
+ where formlet = Paste <$> req (textInput "title" "Title")
+ <*> req (textInput "author" "Author")
+ <*> opt (dropInput "language" "Language")
+ <*> opt (dropInput "channel" "Channel")
+ <*> req (areaInput "paste" "Paste")
@@ -0,0 +1,35 @@
+{-# OPTIONS -Wall #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RecordWildCards #-}
+
+-- | Home page view.
+
+module Amelie.View.Home
+ (page)
+ where
+
+import Amelie.Types
+import Amelie.View.Layout
+
+import Data.Text (Text)
+import Text.Blaze.Html5 as H hiding (map)
+import qualified Text.Blaze.Html5.Attributes as A
+
+-- | Render the home page.
+page :: [Paste] -> Html
+page ps =
+ layoutPage $ Page {
+ pageTitle = "λ Knights!"
+ , pageBody = latest ps
+ }
+
+-- | View the latest pastes.
+latest :: [Paste] -> Html
+latest ps =
+ table $ do
+ tr $ do th $ toHtml ("Title" :: Text)
+ th $ toHtml ("Author" :: Text)
+ pastes ps
+ where pastes = mapM_ $ \Paste{..} -> tr $ do
+ td $ toHtml pasteTitle
+ td $ toHtml pasteAuthor
Oops, something went wrong.

0 comments on commit 4e5d21b

Please sign in to comment.