Build-type:          Simple

Cabal-version:       >=1.2

Executable amelie

  Main-is:           Main.hs

  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

-- | Main entry point.

module Main (main) where

import Amelie.Controller

import Amelie.Controller.Home     as Home

import Amelie.Controller.Paste    as Paste

import Amelie.Controller.Script   as Script

import Amelie.Controller.Style    as Style

import Amelie.Model.Config        (auth)

import Snap.Http.Server

import Snap.Types

import Snap.Util.FileServe

-- | Main entry point.

main :: IO ()

main = do

  p <- newPool auth

  setUnicodeLocale "en_US"

  where config = addListen (ListenHttp "0.0.0.0" 10000) defaultConfig

-- | Serve the controllers.

  routes = [("/css/amelie.css", run Style.handle)

           ,("/js/amelie.js", run Script.handle)

           ,("/css/",serveDirectory "wwwroot/css")

           ,("/js/",serveDirectory "wwwroot/js")

           ,("",run Home.handle)

           ,("/:id",run Paste.handle)

           ]

{-# OPTIONS -Wall #-}

{-# LANGUAGE OverloadedStrings, RecordWildCards, FlexibleInstances #-}

{-# OPTIONS -fno-warn-name-shadowing -fno-warn-orphans #-}

-- | Mini formlets library.

module Text.Formlet

       (Formlet(..)

       ,formlet

       ,req

       ,opt

       ,wrap

       ,textInput

       ,dropInput

       ,areaInput

import           Control.Applicative

import           Control.Monad.Error

import           Control.Monad.Reader

import           Control.Monad.Trans.Error   (ErrorList(..))

import           Data.Monoid.Operator

import           Data.Text                   (Text)

import qualified Data.Text                   as T

import           Data.Text.Encoding

import           Prelude                     hiding ((++))

import           Snap.Types

import           Text.Blaze.Html5            as H

import qualified Text.Blaze.Html5.Attributes as A

-- | A simple formlet data type, fails on first error.

              case formletValue inputs of

                Right v | T.null v -> Right Nothing

                meh -> Just <$> meh

          }

-- | Wrap/transform formlet's HTML.

wrap :: (Html -> Html) -> Formlet Text -> Formlet Text

wrap f formlet@Formlet{..} = formlet { formletHtml = f . formletHtml }

-- | Make a text input formlet with a label.

    p $ H.label $ do

      H.span $ toHtml $ caption ++ ": "

      textarea ! A.name (toValue name) $ toHtml $ fromMaybe "" value

-- | Make a drop down input with a label.

  formlet name $ \value -> do

    p $ H.label $ do

      H.span $ toHtml $ caption ++ ": "

-- | Make a submit (captioned) button.

submitInput :: Text -> Text -> Html

submitInput name caption = p $ do

  p $ H.input ! A.type_ "submit"

  ,output

  ,outputText)

  where

import Amelie.Types

import Control.Monad.Reader       (runReaderT)

import Data.Text.Lazy             (Text,toStrict)

import Database.PostgreSQL.Simple (Pool,withPoolConnection)

import Snap.Types                 (Snap,writeText)

import Text.Blaze                 (Html)

import Text.Blaze.Renderer.Text   (renderHtml)

-- | Run a controller handler.

  withPoolConnection pool $ \conn -> do

    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.

-- | All types.

module Amelie.Types

       (module Amelie.Types.MVC

       ,module Amelie.Types.Paste

       ,module Amelie.Types.Page

       ,module Amelie.Types.Newtypes)

       where

import Amelie.Types.MVC

import Amelie.Types.Paste

import Amelie.Types.Page

import Amelie.Types.Newtypes

  where

import           Amelie.Types

import           Amelie.View.Html

import           Amelie.View.Layout

import           Data.Maybe                  (fromMaybe)

import           Data.Time.Show              (showDateTime)

import           Prelude                     hiding ((++))

import           Text.Blaze.Html5            as H hiding (map)

import qualified Text.Blaze.Html5.Attributes as A

-- | Render the home page.

  layoutPage $ Page {

  , pageName = "home"

  }

-- | Render the home page body.

  createNew form

-- | Create a new paste section.

createNew :: Html -> Html

createNew = lightSection "Create new paste"

-- | View the latest pastes.

  darkSection "Latest pastes" $

    table ! A.width "100%" $ do

      tr $ mapM_ (th . toHtml) $ words "Title Author When Language Channel"

      pastes ps

    where pastes = mapM_ $ \paste@Paste{..} -> tr $ do

                     td $ pasteLink paste pasteTitle

                     td $ toHtml pasteAuthor

                     td $ toHtml $ showDateTime $ pasteDate

    html $ do

      meta ! A.httpEquiv "Content-Type" ! A.content "text/html; charset=UTF-8"

      link ! A.rel "stylesheet" ! A.type_ "text/css" ! A.href "/css/amelie.css"

      js "jquery.js"

      js "amelie.js"

    body ! A.id (toValue pageName) $

      wrap $ do

        logo

        pageBody

import           Amelie.View.Html

import           Amelie.View.Layout

import           Control.Applicative              ((<$>),(<*>),pure)

import           Control.Monad                    (when)

import qualified Data.Map                         as M

import           Data.Monoid.Operator             ((++))

import           Data.Text                        (Text)

import           Data.Text.Encoding               (encodeUtf8)

import           Data.Text.Lazy                   (fromStrict)

import           Data.Time.Show                   (showDateTime)

import           Prelude                          hiding ((++))

import           Safe                             (readMay)

import           Text.Blaze.Html5                 as H hiding (map)

import           Text.Blaze.Html5.Extra

import           Text.Formlet

import           Text.Highlighter.Formatters.Html (format)

import           Text.Highlighter.Lexer           (runLexer)

import           Text.Highlighter.Lexers.Haskell  (lexer)

-- | A formlet for paste submission / editing.

            H.div ! aClass "errors" $

        submitInput "submit" "Submit"

  in (formlet,form)

    where formlet =

                    readMay . concat . map toString >>=

                    return . (fromIntegral :: Integer -> PasteId)

-- | Render the page page.

page :: Paste -> Html

page p@Paste{..} =

  layoutPage $ Page {

  darkSection (fromStrict pasteTitle) $ do

      ul ! aClass "paste-specs" $ do

        detail "Paste" $ pasteLink paste $ "#" ++ show pasteId

        detail "Author" $ pasteAuthor

        detail "Channel" $ maybe "-" show pasteChannel

        detail "Created" $ showDateTime pasteDate

        detail "Raw" $ pasteRawLink paste $ ("View raw link" :: Text)

      clear

    where detail title content = do

pasteContent Paste{..} =

  lightNoTitleSection $ do

    case runLexer lexer (encodeUtf8 (pastePaste ++ "\n")) of

      Right tokens -> format True tokens

      _            -> pre $ toHtml pastePaste

-- | The href link to a paste.

pasteLink :: ToHtml html => Paste -> html -> Html

pasteLink Paste{..} inner = href ("/" ++ show pasteId) inner

-- | The line number part.

lineNumbers :: CSS (Either Property Rule)

lineNumbers = do

  subRule ".linenodiv" $ do

    margin "0 1em 0 0"

    subRule "a" $ do

      textDecoration "none"

      color "#555"

-- | Home page styles.

home :: CSS Rule

home = do

       ,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 {

  }

-- | The controller monad.

newtype Controller a = Controller {

    runController :: ReaderT ControllerState Snap a

{-# LANGUAGE GeneralizedNewtypeDeriving #-}

-- | Newtypes; foreign keys and such.

module Amelie.Types.Newtypes

       where

import Database.PostgreSQL.Simple.Result (Result)

import Database.PostgreSQL.Simple.Param (Param)

newtype PasteId = PasteId Integer

  deriving (Integral,Real,Num,Ord,Eq,Enum,Result,Param)

instance Show PasteId where show (PasteId pid) = show pid

-- | The paste type.

module Amelie.Types.Paste

       (Paste(..)

       where

import Amelie.Types.Newtypes

import Data.Text                               (Text,pack)

import Data.Time                               (UTCTime,zonedTimeToUTC)

import Database.PostgreSQL.Simple.QueryResults (QueryResults(..))

import Text.Blaze                              (ToHtml(..),toHtml)

-- | A paste.

data Paste = Paste {

   pasteId       :: PasteId

  ,pasteTitle    :: Text

  ,pasteDate     :: UTCTime

  ,pasteAuthor   :: Text

  ,pastePaste    :: Text

  ,pasteViews    :: Integer 

  ,pasteParent   :: Maybe PasteId

} deriving Show

-- | A paste submission or edit.

data PasteSubmit = PasteSubmit {

   pasteSubmitId       :: Maybe PasteId

  ,pasteSubmitTitle    :: Text

  ,pasteSubmitAuthor   :: Text

  ,pasteSubmitPaste    :: Text

} deriving Show

instance ToHtml Paste where

  toHtml paste@Paste{..} = toHtml $ pack $ show paste

    , pasteViews = views

    , pasteParent = parent

    }

    where (pid,title,content,author,date,views,language,channel,parent) =

            convertResults field values

-- | Create a new paste.

createPaste :: PasteSubmit -> Model (Maybe PasteId)

createPaste PasteSubmit{..} =

  single ["INSERT INTO paste"

         ,"VALUES"

         ,"returning id"]

-- | Update an existing paste.

updatePaste :: PasteId -> PasteSubmit -> Model ()

updatePaste pid PasteSubmit{..} = do

  _ <- exec (["UPDATE paste"

             ,"SET"]

             ++

             ++

             ["WHERE id = ?"])

            (pasteSubmitTitle

            ,pasteSubmitAuthor

            ,pasteSubmitPaste

            ,pid)

  return ()

    where set key = unwords [key,"=","?"]

module Amelie.Controller.Home

  (handle)

  where

import Amelie.Controller.Paste (pasteForm)

import Amelie.Model

import Amelie.View.Home        (page)

handle :: Controller ()

handle = do

  ,pasteForm)

  where

import Amelie.Types

import Amelie.Model

import Control.Applicative

import Data.Maybe

import Safe

import Snap.Types

import Text.Formlet

-- | Handle the paste page.

handle :: Controller ()

handle = do

  pid <- (>>= readMay) . fmap (toString) <$> getParam "id"

  case pid of

    Nothing -> goHome

    Just (pid :: Integer) -> do

  where goHome = redirect "/"

-- | Control paste editing / submission.

  params <- getParams

  submitted <- isJust <$> getParam "submit"

      value = formletValue getValue params

      errors = either id (const []) value

      val = either (const Nothing) Just $ value

  case val of

    Nothing    -> return ()

    Just paste -> do

      pid <- model $ createOrEdit paste

      maybe (return ()) redirectToPaste pid

  return html

-- | Redirect to the paste's page.