module Main (main) where

import Hpaste.Config

import Hpaste.Controller.Activity as Activity

import Hpaste.Controller.Browse   as Browse

import Hpaste.Controller.Diff     as Diff

import Hpaste.Controller.Home     as Home

import Hpaste.Controller.New      as New

import Hpaste.Controller.Paste    as Paste

import Hpaste.Controller.Raw      as Raw

import Hpaste.Controller.Report   as Report

import Hpaste.Controller.Reported as Reported

import Hpaste.Controller.Style    as Style

import Hpaste.Model.Announcer     (newAnnouncer)

import Hpaste.Types

import Snap.App.Controller

import Snap.Core

import Snap.Http.Server           hiding (Config)

import Snap.Util.FileServe

main = do

  cpath:_ <- getArgs

  config <- getConfig cpath

  announces <- newAnnouncer (configAnnounce config)

  pool <- newPool (configPostgres config)

  setUnicodeLocale "en_US"

 where server = setPort 10000 defaultConfig

-- | Serve the controllers.

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

           ,("/js/",serveDirectory "static/js")

           ,("/css/",serveDirectory "static/css")

           ,("/js/",serveDirectory "static/js")

           ,("/hs/",serveDirectory "static/hs")

           ,("/new/:channel",run (New.handle New.NewPaste))

           ,("/browse",run Browse.handle)

           ,("/activity",run Activity.handle)

           ,("/diff/:this/:that",run Diff.handle)

           ]

  ,getStringMaybe

  ,getPagination

  ,getMyURI)

  where

import Control.Applicative

import Control.Monad.Env

import Control.Monad.Reader       (runReaderT)

import Data.ByteString            (ByteString)

import Data.ByteString.UTF8       (toString)

import Data.Maybe

import Network.URI

import Data.Text.Lazy             (Text,toStrict)

import Database.PostgreSQL.Base   (withPoolConnection)

import Database.PostgreSQL.Simple (Pool)

import Safe                       (readMay)

import Text.Blaze                 (Html)

import Text.Blaze.Renderer.Text   (renderHtml)

-- | Run a controller handler.

  withPoolConnection pool $ \conn -> do

    -- Default to HTML, can be overridden.

    modifyResponse $ setContentType "text/html"

    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 = outputText $ renderHtml $ html

-- | Strictly renders text before outputting it via Snap.

--   This ensures that any lazy exceptions are caught by the Snap

--   handler.

outputText text = do

  let !x = toStrict $ text

  writeText x

-- | Generic redirect to home page.

goHome = redirect "/"

-- | Extract a Just value or go home.

justOrGoHome x m = maybe goHome m x

-- | Get integer parmater.

getInteger name def = do

  pid <- (>>= readMay . toString) <$> getParam name

  maybe (return def) return pid

-- | Get string.

getString name def = do

  pid <- (>>= return . toString) <$> getParam name

  maybe (return def) return pid

-- | Get string (maybe).

getStringMaybe name = do

  pid <- (>>= return . toString) <$> getParam name

  return pid

-- | Get pagination data.

getPagination = do

  p <- getInteger "page" 1

  limit <- getInteger "limit" 35

  uri <- getMyURI

  return Pagination { pnPage = max 1 p

                    , pnLimit = max 1 (min 100 limit)

                    , pnURI = uri

                    , pnResults = 0

                    , pnTotal = 0

                    }

getMyURI = do

  fmap (fromJust .

	parseURI .

	(("http://" ++ domain) ++) .

	toString .

	rqURI)

-- | All types.

module Hpaste.Types

       ,module Hpaste.Types.Channel

       ,module Hpaste.Types.Language

       ,module Hpaste.Types.Page

       ,module Hpaste.Types.Newtypes

       ,module Hpaste.Types.Config

       ,module Hpaste.Types.Activity

       ,module Hpaste.Types.Stepeval

       where

import Hpaste.Types.Paste

import Hpaste.Types.Channel

import Hpaste.Types.Language

import Hpaste.Types.Page

import Hpaste.Types.Newtypes

import Hpaste.Types.Config

import Hpaste.Types.Activity

import Hpaste.Types.Stepeval

import Hpaste.Types.Report

module Hpaste.View.Browse

  (page)

  where

import qualified Data.Text as T

import qualified Data.Text.Lazy as LT

-- | Render the browse page.

page :: Pagination -> [Channel] -> [Language] -> [Paste] -> Maybe String -> Html

page pn chans langs ps mauthor =

  layoutPage $ Page {

import           Network.URI.Params

import           Prelude                     hiding ((++))

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

import qualified Text.Blaze.Html5.Attributes as A

import           Text.Blaze.Extra

-- | A class prefixed with amelie-.

aClass :: AttributeValue -> Attribute

aClass name = A.class_ ("amelie-" ++ name)

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

import Data.Time.Show       (showDateTime)

import Prelude              hiding ((++))

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

-- | Render the reported page.

page :: Pagination -> [Report] -> Html

page pn rs =

  layoutPage $ Page {

       ,Announcer(..))

       where

import Database.PostgreSQL.Simple (ConnectInfo)

import Network.Mail.Mime (Address)

-- | Site-wide configuration.

data Config = Config {

    configAnnounce        :: Announcer

  , configPostgres        :: ConnectInfo

  , configIrcDir          :: FilePath

  , configAdmin           :: Address

  , configSiteAddy        :: Address

  , configCacheDir        :: FilePath

  }

-- | Announcer configuration.

data Announcer = Announcer {

    announceUser :: String

  , announcePass :: String

import Control.Monad.IO      (io)

import Data.Maybe            (mapMaybe)

import Data.Text.Lazy        (pack)

import Data.Time

import Network.Curl.Download

import System.Locale

import Text.Feed.Query

-- | Get commits of this project from a commit feed.

getCommits uri = io $ do

  result <- openAsFeed uri

  case result of

    Left _ -> return []

    Right feed -> return $

      let items = getFeedItems feed

      in mapMaybe makeCommit items

  where makeCommit item = do

          title <- getItemTitle item

          datestr <- getItemDate item

          date <- parseDateString datestr

          link <- getItemLink item

import           Data.Text.Lazy          (Text,pack)

import           Data.Text.Lazy.Encoding

import qualified Data.Text.Lazy.IO       as T

import           Network

import           Prelude                 hiding ((++))

import           System.IO

-- | Start a thread and return a channel to it.

newAnnouncer :: Announcer -> IO (Chan Text)

newAnnouncer config = do

  cont h

  lines <- getChanContents ans

  forM_ lines $ \line -> send h line

-- | Announce something to the IRC.

announce channel line = do

  chan <- env modelStateAnns

  io $ writeChan chan $ "PRIVMSG " ++ channel ++ " :" ++ line

module Hpaste.Model.Channel

  (getChannels)

  where

import Hpaste.Types

-- | Get the channels.

getChannels =

  queryNoParams ["SELECT *"

                ,"FROM channel"]

module Hpaste.Model.Language

  (getLanguages)

  where

import Hpaste.Types

-- | Get the languages.

getLanguages =

  queryNoParams ["SELECT id,name,title"

                ,"FROM language"

                ,"WHERE visible"

                ,"ORDER BY ordinal,title ASC"]

  ,getHints

  ,validNick)

  where

import Hpaste.Types

import Hpaste.Model.Announcer

import Control.Applicative    ((<$>),(<|>))

import Control.Exception as E

import Control.Monad

import Data.Text              (Text,unpack,pack)

import Data.Text.IO           as T (writeFile)

import Data.Text.Lazy         (fromStrict)

import Language.Haskell.HLint

import Prelude                hiding ((++))

import System.Directory

import System.FilePath

-- | Count public pastes.

countPublicPastes mauthor = do

  rows <- single ["SELECT COUNT(*)"

                 ,"FROM public_toplevel_paste"

		 ,"WHERE (? IS NULL) OR (author = ?)"]

		 (mauthor,mauthor)

  return $ fromMaybe 0 rows

-- | Get the latest pastes.

getLatestPastes =

  queryNoParams ["SELECT *"

                ,"FROM public_toplevel_paste"

                ,"ORDER BY id DESC"

                ,"LIMIT 20"]

-- | Get some paginated pastes.

getSomePastes mauthor Pagination{..} =

  query ["SELECT *"

	,"FROM public_toplevel_paste"

	,"WHERE (? IS NULL) OR (author = ?)"

	,"ORDER BY id DESC"

	,"OFFSET " ++ show (max 0 (pnPage - 1) * pnLimit)

	,"LIMIT " ++ show pnLimit]

        (mauthor,mauthor)

-- | Get a paste by its id.

getPasteById pid =

  listToMaybe <$> query ["SELECT *"

                        ,"FROM public_paste"

                        ,"WHERE id = ?"]

                        (Only pid)

-- | Get annotations of a paste.

getAnnotations pid =

  query ["SELECT *"

        ,"FROM public_paste"

        ,"WHERE annotation_of = ?"

        ,"ORDER BY id ASC"]

        (Only pid)

-- | Get revisions of a paste.

getRevisions pid = do

  query ["SELECT *"

        ,"FROM public_paste"

        ,"WHERE revision_of = ? or id = ?"

        ,"ORDER BY id DESC"]

        (pid,pid)

-- | Create a paste, or update an existing one.

createOrUpdate langs chans paste@PasteSubmit{..} = do

  case pasteSubmitId of

    Nothing  -> createPaste langs chans paste

    Just pid -> do updatePaste pid paste

                   return $ Just pid

-- | Create a new paste (possibly annotating an existing one).

createPaste langs chans ps@PasteSubmit{..} = do

  res <- single ["INSERT INTO paste"

                ,"(title,author,content,channel,language,annotation_of,revision_of)"

                ,"VALUES"

                ,"(?,?,?,?,?,?,?)"

        just j m = maybe (return ()) m j

        ann_pid = case pasteSubmitType of AnnotationOf pid -> Just pid; _ -> Nothing

        rev_pid = case pasteSubmitType of RevisionOf pid -> Just pid; _ -> Nothing

-- | Create the hints for a paste.

createHints ps pid = do

  hints <- generateHintsForPaste ps pid

  forM_ hints $ \hint ->

    exec ["INSERT INTO hint"

         ,"(paste,type,content)"

         (pid

         ,suggestionSeverity hint

         ,show hint)

-- | Announce the paste.

announcePaste ptype channel PasteSubmit{..} pid = do

  conf <- env modelStateConfig

  verb <- getVerb

  announce (fromStrict channel) $ fromStrict $ do

    nick ++ " " ++ verb ++ " “" ++ pasteSubmitTitle ++ "” at " ++ link conf

validNick s = first && all ok s && length s > 0 where

  ok c = isDigit c || isLetter c || elem c "-_/\\;()[]{}?`'"

  first = all (\c -> isDigit c || isLetter c) $ take 1 s

-- | Get hints for a Haskell paste from hlint.

generateHintsForPaste PasteSubmit{..} (fromIntegral -> pid :: Integer) = io $

  E.catch (generateHints (show pid) pasteSubmitPaste)

          (\SomeException{} -> return [])

-- | Get hints for a Haskell paste from hlint.

  exists <- doesFileExist tmp

  unless exists $ T.writeFile tmp $ contents

  !hints <- hlint [tmp,"--quiet","--ignore=Parse error"]

  return hints

getHints pid =

  query ["SELECT type,content"

        ,"FROM hint"

        ,"WHERE paste = ?"]

        (Only pid)

-- | Update an existing paste.

updatePaste pid PasteSubmit{..} = do

  _ <- exec (["UPDATE paste"

             ,"SET"]

             ++

             [intercalate ", " (map set (words fields))]

module Hpaste.Model.Report

 (getSomeReports,createReport,countReports)

  where

import qualified Data.Text.Lazy as LT

-- | Get some paginated reports.

getSomeReports Pagination{..} =

  queryNoParams ["SELECT created,paste,comments"

                ,"FROM report"

                ,"ORDER BY id DESC"

                ,"OFFSET " ++ show (max 0 (pnPage - 1) * pnLimit)

                ,"LIMIT " ++ show pnLimit]

-- | Count reports.

countReports = do

  rows <- singleNoParams ["SELECT COUNT(*)"

                         ,"FROM report"]

  return $ fromMaybe 0 rows

-- | Create a new report.

createReport rs@ReportSubmit{..} = do

  res <- single ["INSERT INTO report"

                ,"(paste,comments)"

                ,"VALUES"

                ,"(?,?)"

        resetCacheModel (Key.Revision (fromIntegral pid))

  reset rsPaste

  sendReport rs

  return res

sendReport ReportSubmit{..} = do

  conf <- env modelStateConfig

  _ <- io $ simpleMail (configAdmin conf)

		       (configSiteAddy conf)

		       (T.pack ("Paste reported: #" ++ show rsPaste))

module Hpaste.Controller.Activity

  (handle)

  where

import Hpaste.Controller.Cache (cache)

import Hpaste.Model.Activity   (getCommits)

import Hpaste.Types.Cache      as Key

import Hpaste.View.Activity    (page)

import Control.Monad.Env       (env)

-- | Display commit history.

handle = do

  html <- cache Key.Activity $ do

    uri <- env $ configCommits . controllerStateConfig

    repourl <- env $ configRepoURL . controllerStateConfig

    commits <- model $ getCommits uri

module Hpaste.Controller.Browse

  (handle)

  where

import Hpaste.Model.Channel  (getChannels)

import Hpaste.Model.Language (getLanguages)

import Hpaste.Model.Paste    (getSomePastes,countPublicPastes)

import Hpaste.View.Browse    (page)

-- | Browse all pastes.

handle = do

  pn <- getPagination

  author <- getStringMaybe "author"

  total <- model $ countPublicPastes author

  pastes <- model $ getSomePastes author pn

       where

import           Hpaste.Types.Cache

import           Hpaste.Types.Config

import           Control.Concurrent

import           Control.Monad.IO         (io)

import           Control.Monad.Reader     (asks)

import qualified Data.Map                 as M

import           Data.Text.Lazy           (Text)

import qualified Data.Text.Lazy.IO as T

import           System.Directory

import           Text.Blaze.Html5         (Html)

import           Text.Blaze.Renderer.Text (renderHtml)

-- | Create a new cache.

newCache = do

  var <- newMVar M.empty

  return $ Cache var

-- | Cache conditionally.

cacheIf pred key generate =

  if pred

     then cache key generate

     else fmap (fmap renderHtml) generate

-- | Generate and save into the cache, or retrieve existing from the

-- | cache.

cache key generate = do

  tmpdir <- asks (configCacheDir . controllerStateConfig)

  let cachePath = tmpdir ++ "/" ++ keyToString key

  exists <- io $ doesFileExist cachePath

  if exists

	       Just text' -> do io $ T.writeFile cachePath text'

	       	    	        return text

               Nothing -> return text

-- | Reset an item in the cache.

resetCache key = do

  tmpdir <- asks (configCacheDir . controllerStateConfig)

  io $ do

   let cachePath = tmpdir ++ "/" ++ keyToString key

   exists <- io $ doesFileExist cachePath

   when exists $ removeFile cachePath

-- | Reset an item in the cache.

resetCacheModel key = do

  tmpdir <- asks (configCacheDir . modelStateConfig)

  io $ do

   let cachePath = tmpdir ++ "/" ++ keyToString key

   exists <- io $ doesFileExist cachePath

module Hpaste.Controller.Diff

  (handle)

  where

import Hpaste.Controller.Paste (withPasteKey)

import Hpaste.View.Diff        (page)

-- | Diff one paste with another.

handle = do

  withPasteKey "this" $ \this ->

    withPasteKey "that" $ \that ->

      output $ page this that

module Hpaste.Controller.Home

  (handle)

  where

import Hpaste.Controller.Cache (cache)

import Hpaste.Controller.Paste (pasteForm)

import Hpaste.Model.Channel    (getChannels)

import Hpaste.Model.Language   (getLanguages)

import Hpaste.Model.Paste      (getLatestPastes)

import Hpaste.Types.Cache      as Key

import Hpaste.View.Home        (page)

-- | Handle the home page, display a simple list and paste form.

handle = do

  html <- cache Key.Home $ do

    pastes <- model $ getLatestPastes

    chans <- model $ getChannels

    langs <- model $ getLanguages

module Hpaste.Controller.New

  (handle,NewStyle(..))

  where

import Hpaste.Controller.Paste (pasteForm,getPasteId)

import Hpaste.Model.Channel    (getChannels)

import Hpaste.Model.Language   (getLanguages)

import Hpaste.Model.Paste      (getPasteById)

import Hpaste.View.Annotate    as Annotate (page)

import Hpaste.View.Edit        as Edit (page)

import Hpaste.View.New         as New (page)

import Control.Applicative

import Data.Text.Encoding      (decodeUtf8)

data NewStyle = NewPaste | AnnotatePaste | EditPaste

 deriving Eq

-- | Make a new paste.

handle style = do

  chans <- model $ getChannels

  langs <- model $ getLanguages

  defChan <- fmap decodeUtf8 <$> getParam "channel"

  pid <- if style == NewPaste then return Nothing else getPasteId

  ,getPasteIdKey

  ,withPasteKey)

  where

import Hpaste.Types

import Hpaste.Controller.Cache (cache,resetCache)

import Hpaste.Model.Channel    (getChannels)

import Hpaste.Model.Language   (getLanguages)

import Hpaste.Model.Paste

import Hpaste.Types.Cache      as Key

import Hpaste.View.Paste       (pasteFormlet,page)

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

import Data.String             (fromString)

import Data.Text               (Text)

import Prelude                 hiding ((++))

import Safe

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

import Text.Formlet

-- | Handle the paste page.

handle revision = do

  pid <- getPasteId

  justOrGoHome pid $ \(pid :: Integer) -> do

      html <- cache (if revision then Key.Revision pid else Key.Paste pid) $ do

        paste <- model $ getPasteById (fromIntegral pid)

	    , ppRevision = revision

            }

      justOrGoHome html outputText

-- | Control paste annotating / submission.

pasteForm channels languages defChan annotatePaste editPaste = do

  params <- getParams

  submitted <- isJust <$> getParam "submit"

  revisions <- maybe (return []) (model . getRevisions) (fmap pasteId (annotatePaste <|> editPaste))

  let formlet = PasteFormlet {

      pid <- model $ createPaste languages channels paste

      maybe (return ()) redirectToPaste pid

  return html

-- | Redirect to the paste's page.

redirectToPaste (PasteId pid) =

  redirect $ "/" ++ fromString (show pid)

-- | Get the paste id.

getPasteId = (fmap toString >=> readMay) <$> getParam "id"

-- | Get the paste id by a key.

getPasteIdKey key = (fmap toString >=> readMay) <$> getParam key

-- | With the

withPasteKey key with = do

  pid <- getPasteIdKey key

  justOrGoHome pid $ \(pid :: Integer) -> do

    paste <- model $ getPasteById (fromIntegral pid)

    justOrGoHome paste $ \paste -> do

module Hpaste.Controller.Raw

  (handle)

  where

import Hpaste.Types

import Control.Applicative

import Data.ByteString.UTF8 (toString)

import Data.Maybe

import Data.Text.Lazy       (fromStrict)

import Prelude              hiding ((++))

import Safe

-- | Handle the paste page.

handle = do

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

  case pid of

    Nothing -> goHome

    Just (pid :: Integer) -> do

module Hpaste.Controller.Report

  (handle)

  where

import           Hpaste.Model.Paste   (getPasteById)

import           Hpaste.Model.Report

import           Hpaste.View.Report

import qualified Hpaste.View.Thanks   as Thanks

import           Control.Applicative

import           Data.ByteString.UTF8 (toString)

import           Data.Maybe

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

import           Data.Text            (unpack)

import           Prelude              hiding ((++))

import           Safe

import           Text.Blaze.Html5     as H hiding (output,map,body)

import           Text.Formlet

-- | Handle the report/delete page.

handle = do

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

  case pid of

    Nothing -> goHome

    Just (pid :: Integer) -> do

                               "Thanks, your comments have " ++

                               "been reported to the administrator."

        Nothing -> maybe goHome (output . page frm) paste

-- | Report form.

exprForm = do

  params <- getParams

  submitted <- isJust <$> getParam "submit"

  let formlet = ReportFormlet {

          rfSubmitted = submitted

module Hpaste.Controller.Reported

  (handle)

  where

import Hpaste.Model.Report   (getSomeReports,countReports)

import Hpaste.View.Reported  (page)

-- | List the reported pastes.

handle = do

  pn <- getPagination

  total <- model countReports

  reports <- model $ getSomeReports pn

  let pn' = pn { pnResults = fromIntegral (length reports)

module Hpaste.Controller.Style

  (handle)

  where

import Hpaste.View.Style (style)

handle = do

  modifyResponse $ setContentType "text/css"

  outputText $ style