{-# OPTIONS_GHC -fth -fglasgow-exts #-}
-----------------------------------------------------------------------------
-- |
-- Module      : PasteState
-- Copyright   : (c) Eric Mertens 2007
-- License     : BSD3-style (see LICENSE)
-- 
-- Maintainer  : emertens@gmail.com
-- Stability   : unstable
-- Portability : portable
--
-----------------------------------------------------------------------------
--
-- The basic state of the paste server
--

module PasteState (
      currentId
    , PasteState
    , Entry
    , entryNick
    , entryTitle
    , entryContent
    , entryTime
    , getEntries
    , storeEntry
    , storeAnnotation
    , allEntries
    , newEntry
    , deleteEntry

    , TimeStamp

    , gzip
    , gunzip

    , PEv, Paste, PasteM -- type synonyms for events
  ) where

import HAppS

import Prelude hiding (reverse, length)
import Control.Monad.State (modify, gets)
import Data.Sequence
import Data.Foldable (toList)
import Data.Int (Int64)
import qualified Data.ByteString.Char8 as B
import qualified Data.ByteString.Lazy.Char8  as L
import Control.Monad
import Text.XHtml.Strict (Html, showHtml)

import Data.Binary
import Codec.Compression.GZip

------------------------------------------------------------------------

newtype GZBytestring = GZ B.ByteString

-- | An individual paste
data Entry = Entry
    { entryNick, entryTitle :: !String
    , entryContentGz        :: !GZBytestring -- a compressed in-memory bytestring
    , entryTime             :: !Int64 }

-- | The PasteState, the state of our system
data PasteState = PasteState { pastes :: !(Seq [Entry]) }

$(inferStartState ''PasteState)
$(inferRecordUpdaters ''PasteState)

-- | Uncompress a content field on the fly
entryContent :: Entry -> B.ByteString
entryContent e' = gunzip gz
    where GZ gz = entryContentGz e'

--
-- Fast serialisation using Data.Binary
--
instance Binary PasteState where
    put (PasteState xs) = put xs
    get = liftM PasteState get

instance Binary Entry where
    put (Entry nk ti cn tm) = put nk >> put ti >> put cn >> put tm
    get = liftM4 Entry get get get get

-- | Write out a raw compressed bytestring
instance Binary GZBytestring where
    put (GZ b) = put b
    get        = liftM GZ get

------------------------------------------------------------------------

-- | Compress a strict ByteString
gzip   :: B.ByteString -> B.ByteString
gzip   = B.concat . L.toChunks . compress . L.fromChunks . (:[])

-- | Uncompress a strict ByteString
gunzip :: B.ByteString -> B.ByteString
gunzip = B.concat . L.toChunks . decompress . L.fromChunks . (:[])

------------------------------------------------------------------------

-- | Serialisation of the server state

instance Serialize PasteState where
        typeString _  = "PasteState_0"

        -- Compress everything. Currently has to go via String :( 
        encodeFPS     a = return . L.toChunks . compress . encode $ a
        encodeStringM a = return . L.unpack . compress . encode $ a
        decodeStringM s = L.length ps `seq` return (decode (decompress ps), "")
            where ps = L.pack s

------------------------------------------------------------------------

-- | A convenient alias for time
type TimeStamp = Int64

------------------------------------------------------------------------

--
-- some useful synonyms for this hairy stuff
--
type PEv a    = Ev PasteState Request a
type Paste    = PEv (Either Request Html)
type PasteM m = PEv (Either Request (m Result))

instance ToMessage Html where
  toMessageM x = liftM (addHeader "content-type" "text/html") . toMessageM . showHtml $ x

-- | Build a new entry. Shallow wrapper over the Entry constructor
-- Compreses the input bytestring using gzip.
newEntry :: String -> String -> B.ByteString -> TimeStamp -> Entry
newEntry nick title content t' = Entry nick title (GZ contentgz) t'
    where contentgz = gzip . B.filter (/='\r') $ content

-- | The current user id (this is a unique supply..)
currentId :: PEv Int
currentId = gets (length . pastes)

allEntries :: PEv [(Int, [Entry])]
allEntries = gets $ (\ps ->
  let n = length ps - 1 in
  [x | x <- Prelude.zip [n,n-1..] . toList . reverse $ ps
     , not . Prelude.null . snd $ x]) . pastes

getEntries :: Int -> PEv [Entry]
getEntries pasteId = gets $ (`index` pasteId) . pastes

storeEntry :: Entry -> PEv ()
storeEntry entry = withPastes $ modify (|> [entry])

storeAnnotation :: Int -> Entry -> PEv ()
storeAnnotation pasteId entry = withPastes $
  modify $ \ps -> case ps `index` pasteId of
                    [] -> ps
                    p  -> update pasteId (p ++ [entry]) ps

deleteEntry :: Int -> PEv ()
deleteEntry pasteId = withPastes $ modify $ update pasteId []