Json.hs

module CQRSExample.Json
       ( jsonServerPart
       ) where

import           Control.Applicative (optional)
import           Control.Monad (liftM, void)
import           Control.Monad.Trans.Class (lift)
import           CQRSExample.Command (logWork, createProject, createTask, starTask, unstarTask)
import           CQRSExample.Events (Event)
import           CQRSExample.Query
import           Data.Aeson (ToJSON, encode, toJSON)
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as BSL
import           Data.CQRS (EventStore, runTransactionT)
import           Data.CQRS.GUID (GUID, hexEncode, hexDecode)
import           Data.List (groupBy)
import qualified Data.Map as M
import           Data.Maybe (fromJust)
import qualified Data.Text as T
import qualified Data.Text.Lazy as TL
import qualified Data.Text.Encoding as TE
import           Data.Time.Calendar (Day)
import           Data.Time.Format (parseTime)
import           Database.HDBC (IConnection)
import           Happstack.Lite
import           Happstack.Server.RqData (lookRead)
import           System.Locale (defaultTimeLocale)

-- Instances.
instance ToJSON Day where
  toJSON d = toJSON $ show d

-- Parse request parameter to date. Fails the request
-- if the parameter is absent.
lookDay :: String -> ServerPart Day
lookDay pn = do
  p <- lookText pn
  case parseTime defaultTimeLocale "%F" $ TL.unpack $ p of
    Just d -> return d
    Nothing -> fail $ "Missing parameter '" ++ pn ++ "'"

-- Retrieve a GUID parameter.
lookGUID :: String -> ServerPart (Maybe GUID)
lookGUID name = do
  bs <- optional $ lookBS name
  case bs of
    Nothing -> return Nothing
    Just bs' -> return $ hexDecode $ BS.concat $ BSL.toChunks $ bs'

-- Serve JSON ok response.
okJson :: ToJSON a => a -> ServerPart Response
okJson a = ok $ toResponseBS "text/json" $ encode a

-- Serve a list generated by a monadic action as a JSON response.
listJson :: (IConnection c, ToJSON b) => c -> (c -> IO [a]) -> (a -> b) -> ServerPart Response
listJson connection lister f = do
  p <- liftM (map f) $ lift $ lister connection
  okJson $ p

-- Serve JSON project list.
projectsJson :: IConnection c => c -> EventStore Event -> ServerPart Response
projectsJson connection eventStore =
  msum [ method GET >> getProjects
       , method POST >> postProjects
       ]
  where
    getProjects :: ServerPart Response
    getProjects = do
      (listJson connection qProjectList
       (\(g,pn,psd) ->
         M.fromList [ (T.pack "id"        , TE.decodeUtf8 $ hexEncode g)
                    , (T.pack "name"      , pn)
                    , (T.pack "short_desc", psd)
                    ]))
    postProjects = do
      pn <- fmap TL.toStrict $ lookText "name"
      pd <- fmap TL.toStrict $ lookText "shortDescription"
      pid <- lift $ runTransactionT eventStore $ do
        createProject pn pd
      ok $ toResponse $ hexEncode pid

-- Serve JSON task list.
tasksJson :: IConnection c => c -> EventStore Event -> String -> ServerPart Response
tasksJson connection eventStore userName =
  msum [ method GET >> getTasks
       , method POST >> postTasks
       ]
  where
    getTasks :: ServerPart Response
    getTasks = do
      projectId <- lookGUID "projectId"
      (listJson connection (qTaskList userName projectId)
       (\(g,tsd,starred) ->
         M.fromList [ (T.pack "id"               , toJSON $ TE.decodeUtf8 $ hexEncode g)
                    , (T.pack "short_description", toJSON $ tsd)
                    , (T.pack "starred"          , toJSON $ starred)
                    ]))

    postTasks :: ServerPart Response
    postTasks = do
      mpid <- fmap (hexDecode . BS.concat . BSL.toChunks) $ lookBS "projectId"
      case mpid of
        Nothing -> fail "Invalid project ID"
        Just pid -> do
          tsd <- fmap TL.toStrict $ lookText "shortDescription"
          tid <- lift $ runTransactionT eventStore $ do
            createTask pid tsd
          ok $ toResponse $ hexEncode tid

-- Serve JSON time sheet.
timeSheetJson :: IConnection c => c -> String -> ServerPart Response
timeSheetJson connection userName = do
  fromDate <- lookDay "fromDate"
  toDate <- lookDay "toDate"
  -- Generate the time sheet data.
  timeSheet <- lift $ qTimeSheet fromDate toDate userName connection
  -- Group by tasks to make the front end manipulation a little easier.
  let groupedTimeSheet =
        groupBy (\(tid1,_,_,_) (tid2,_,_,_) -> (tid1==tid2)) timeSheet
  -- Generate the JSON data.
  okJson $ map
    (\entries ->
      case entries of
        [] -> M.fromList []
        ((tid,tsd,_,_):_) ->
          M.fromList [ (T.pack "task_id", toJSON $ hexEncode tid)
                     , (T.pack "task_short_description", toJSON tsd)
                     , (T.pack "timeSheet",
                        toJSON $ map (\(_,_,day,total) ->
                                       M.fromList [ (T.pack "date", toJSON $ day)
                                                  , (T.pack "total", toJSON total) ] ) entries) ])
    groupedTimeSheet

-- Stars server part.
starsServerPart :: IConnection c => c -> EventStore Event -> String -> ServerPart Response
starsServerPart connection eventStore userName = do
  msum [ method POST >> postStars
       ]
  where
    postStars :: ServerPart Response
    postStars = do
      mTaskId <- fmap (hexDecode . BS.concat . BSL.toChunks) $ lookBS "taskId"
      case mTaskId of
        Nothing -> fail "Invalid task ID"
        Just taskId -> do
          mUserId <- lift $ qUserIdFromUserName connection (T.pack userName)        -- TODO: Move this lookup to the authentication server part.
          case mUserId of
            Nothing -> fail "Invalid user name"
            Just userId -> do
              starredS <- lookBS "starred"
              case starredS of
                "true" -> lift $ runTransactionT eventStore $ void $ starTask taskId userId
                "false" -> lift $ runTransactionT eventStore $ void $ unstarTask taskId userId
                _ -> fail "Invalid input"
              ok $ toResponse ("OK" :: String)

-- Log work.
logWorkPost :: EventStore Event -> ServerPart Response
logWorkPost eventStore = do
  -- FIXME: Avoid fromJust + lookRead! This is extremely crashy.
  taskId <- liftM (fromJust . hexDecode . BS.concat . BSL.toChunks) $ lookBS "taskId"
  duration <- lookRead "duration"
  comment <- lookText "comment"
  date <- lookDay "date"
  let userId = fromJust $ hexDecode ""    -- FIXME: Use USER ID of authenticated user!
  lift $ runTransactionT eventStore $ do
    void $ logWork taskId userId date duration (TL.toStrict comment)
  ok $ toResponse ("" :: String)

-- Serve JSON data.
jsonServerPart :: IConnection c => c -> EventStore Event -> String -> ServerPart Response
jsonServerPart conn eventStore userName =
  msum
  [ dir "projects" $ projectsJson conn eventStore
  , dir "tasks" $ tasksJson conn eventStore userName
  , dir "stars" $ starsServerPart conn eventStore userName
  , dir "time-sheet" $ timeSheetJson conn userName
  , dir "do-log-work" $ logWorkPost eventStore
  ]