{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE FlexibleContexts #-}

{-|

CRUD for JSON data with Redis storage.

Can be used as Backbone.sync backend.

-}

module Snap.Snaplet.Redson 
    ( Redson
    , redsonInit
    )

where

import Prelude hiding (concat, FilePath, id)

import Control.Monad.State hiding (put)
import Data.Functor

import Data.Aeson as A

import qualified Data.ByteString as B
import qualified Data.ByteString.Lazy as LB (ByteString)

import Data.Configurator

import Data.Lens.Common
import Data.Lens.Template

import Data.List (foldl1', intersect, union)
import qualified Data.Map as M

import Data.Maybe

import Snap.Core
import Snap.Snaplet
import Snap.Snaplet.Auth
import Snap.Snaplet.RedisDB

import Network.WebSockets
import Network.WebSockets.Snap
import qualified Network.WebSockets.Util.PubSub as PS

import Database.Redis hiding (auth)


import qualified Snap.Snaplet.Redson.Snapless.CRUD as CRUD
import Snap.Snaplet.Redson.Snapless.Metamodel
import Snap.Snaplet.Redson.Snapless.Metamodel.Loader (loadModels)
import Snap.Snaplet.Redson.Permissions
import Snap.Snaplet.Redson.Search
import Snap.Snaplet.Redson.Util


------------------------------------------------------------------------------
-- | Redson snaplet state type.
data Redson b = Redson
             { _database :: Snaplet RedisDB
             , auth :: Lens b (Snaplet (AuthManager b))
             , events :: PS.PubSub Hybi10
             , models :: M.Map ModelName Model
             , transparent :: Bool
             -- ^ Operate in transparent mode (not security checks).
             }

makeLens ''Redson


------------------------------------------------------------------------------
-- | Extract model name from request path parameter.
--
-- Note that this works for transparent mode even if model is unknown.
getModelName:: MonadSnap m => m ModelName
getModelName = fromParam "model"


------------------------------------------------------------------------------
-- | Extract model instance id from request parameter.
getModelId:: MonadSnap m => m CRUD.InstanceId
getModelId = fromParam "id"



------------------------------------------------------------------------------
-- | Extract model instance Redis key from request parameters.
getInstanceKey :: MonadSnap m => m B.ByteString
getInstanceKey = liftM2 CRUD.instanceKey getModelName getModelId

------------------------------------------------------------------------------
-- | Try to get Model for current request.
--
-- TODO: Return special model for transparent-mode.
getModel :: (MonadSnap m, MonadState (Redson b) m) => m (Maybe Model)
getModel = liftM2 M.lookup getModelName (gets models)


------------------------------------------------------------------------------
-- | Perform action with AuthManager.
withAuth :: (MonadState (Redson b1) (m b1 v), MonadSnaplet m) =>
            m b1 (AuthManager b1) b -> m b1 v b
withAuth action = do
  am <- gets auth
  return =<< withTop am action


------------------------------------------------------------------------------
-- | Top-level (per-form) security checking.
--
-- Reject request if no user is logged in or metamodel is unknown or
-- user has no permissions for CRUD method; otherwise perform given
-- handler action with user and metamodel as arguments. In transparent
-- mode, always perform the action without any checks.
--
-- If security checks are in effect and succeed, action is always
-- called with Just constructor of Maybe Model.
withCheckSecurity :: (Either SuperUser AuthUser -> Maybe Model
                  -> Handler b (Redson b) ())
                  -> Handler b (Redson b) ()
withCheckSecurity action = do
  mdl <- getModel
  trs <- gets transparent
  case trs of
    True -> action (Left SuperUser) mdl
    False -> do
      m <- getsRequest rqMethod
      au <- withAuth currentUser
      case (au, mdl) of
        (Nothing, _) -> handleError unauthorized
        (_, Nothing) -> handleError forbidden
        (Just user, Just model) ->
           case (elem m $ getModelPermissions (Right user) model) of
             True -> action (Right user) mdl
             False -> handleError forbidden


------------------------------------------------------------------------------
-- | Builder for WebSockets message containing JSON describing
-- creation or deletion of model instance.
modelMessage :: B.ByteString
             -> (ModelName
                 -> CRUD.InstanceId
                 -> Network.WebSockets.Message p)
modelMessage event = \model id ->
    let
        response :: [(B.ByteString, B.ByteString)]
        response = [("event", event),
                    ("id", id),
                    ("model", model)]
    in
      DataMessage $ Text $ A.encode $ M.fromList response


-- | Model instance creation message.
creationMessage :: ModelName
                -> CRUD.InstanceId
                -> Network.WebSockets.Message p
creationMessage = modelMessage "create"


-- | Model instance deletion message.
deletionMessage :: ModelName
                -> CRUD.InstanceId
                -> Network.WebSockets.Message p
deletionMessage = modelMessage "delete"


------------------------------------------------------------------------------
-- | Encode Redis HGETALL reply to B.ByteString with JSON.
commitToJson :: Commit -> LB.ByteString
commitToJson r = A.encode r


------------------------------------------------------------------------------
-- | Decode B.ByteString with JSON to map of hash keys & values for
-- Redis HMSET (still to be `toList`-ed).
--
-- Return Nothing if parsing failed.
--
-- Note that if JSON object contains `null` values, conversion will
-- fail.
jsonToCommit :: LB.ByteString -> Maybe Commit
jsonToCommit s =
    let
        j = A.decode s
    in
      case j of
        Nothing -> Nothing
        Just m ->
             -- Omit fields with null values and "id" key
            Just (M.filterWithKey 
                       (\k _ -> k /= "id")
                       m)


------------------------------------------------------------------------------
-- | Handle instance creation request
--
-- *TODO*: Use readRequestBody
post :: Handler b (Redson b) ()
post = ifTop $ do
  withCheckSecurity $ \au mdl -> do
    -- Parse request body to list of pairs
    r <- jsonToCommit <$> getRequestBody
    case r of
      Nothing -> handleError serverError
      Just commit -> do
        when (not $ checkWrite au mdl commit) $
             handleError forbidden

        mname <- getModelName
        Right newId <- runRedisDB database $
           CRUD.create mname commit (maybe [] indices mdl)

        ps <- gets events
        liftIO $ PS.publish ps $ creationMessage mname newId

        -- http://www.w3.org/Protocols/rfc2616/rfc2616-sec9.html#sec9.5:
        --
        -- the response SHOULD be 201 (Created) and contain an entity which
        -- describes the status of the request and refers to the new
        -- resource
        modifyResponse $ (setContentType "application/json" . setResponseCode 201)
        -- Tell client new instance id in response JSON.
        writeLBS $ A.encode $ M.insert "id" newId commit
        return ()


------------------------------------------------------------------------------
-- | Read instance from Redis.
read' :: Handler b (Redson b) ()
read' = ifTop $ do
  withCheckSecurity $ \au mdl -> do
    key <- getInstanceKey
    r <- runRedisDB database $ do
      Right r <- hgetall key
      return r

    when (null r) $
         handleError notFound

    modifyResponse $ setContentType "application/json"
    writeLBS $ commitToJson $ (filterUnreadable au mdl (M.fromList r))
    return ()


------------------------------------------------------------------------------
-- | Handle PUT request for existing instance in Redis.
--
-- TODO Report 201 if could create new instance.
-- (http://www.w3.org/Protocols/rfc2616/rfc2616-sec9.html#sec9.6)
put :: Handler b (Redson b) ()
put = ifTop $ do
  withCheckSecurity $ \au mdl -> do
    -- Parse request body to list of pairs
    r <- jsonToCommit <$> getRequestBody
    case r of
      Nothing -> handleError serverError
      Just j -> do
        when (not $ checkWrite au mdl j) $
             handleError forbidden

        id <- getModelId
        mname <- getModelName        
        Right _ <- runRedisDB database $ 
           CRUD.update mname id j (maybe [] indices mdl)
        modifyResponse $ setResponseCode 204
        return ()


------------------------------------------------------------------------------
-- | Delete instance from Redis (including timeline).
delete :: Handler b (Redson b) ()
delete = ifTop $ do
  withCheckSecurity $ \_ mdl -> do
    id <- getModelId
    mname <- getModelName
    key <- getInstanceKey

    r <- runRedisDB database $ do
      -- http://www.w3.org/Protocols/rfc2616/rfc2616-sec9.html#sec9.7
      --
      -- A successful response SHOULD be 200 (OK) if the response includes
      -- an entity describing the status
      Right r <- hgetall key
      return r

    when (null r) $
         handleError notFound

    runRedisDB database $ CRUD.delete mname id (maybe [] indices mdl)

    modifyResponse $ setContentType "application/json"
    writeLBS (commitToJson (M.fromList r))

    ps <- gets events
    liftIO $ PS.publish ps $ deletionMessage mname id


------------------------------------------------------------------------------
-- | Serve list of 10 latest instances stored in Redis.
--
-- *TODO*: Adjustable item limit.
timeline :: Handler b (Redson b) ()
timeline = ifTop $ do
  withCheckSecurity $ \_ _ -> do
    mname <- getModelName

    r <- runRedisDB database $ do
      Right r <- lrange (CRUD.modelTimeline mname) 0 9
      return r

    modifyResponse $ setContentType "application/json"
    writeLBS (enc' r)
      where
          enc' :: [B.ByteString] -> LB.ByteString
          enc' r = A.encode r


------------------------------------------------------------------------------
-- | WebSockets handler which pushes instance creation/deletion events
-- to client.
--
-- TODO: Check for login?
modelEvents :: Handler b (Redson b) ()
modelEvents = ifTop $ do
  ps <- gets events
  liftSnap $ runWebSocketsSnap (\r -> do
                                  acceptRequest r
                                  PS.subscribe ps)


------------------------------------------------------------------------------
-- | Serve JSON metamodel with respect to current user and field
-- permissions.
--
-- TODO: Cache this wrt user permissions cache.
metamodel :: Handler b (Redson b) ()
metamodel = ifTop $ do
  withCheckSecurity $ \au mdl -> do
    case mdl of
      Nothing -> handleError notFound
      Just m -> do
        modifyResponse $ setContentType "application/json"
        writeLBS (A.encode $ stripModel au m)


------------------------------------------------------------------------------
-- | Serve JSON array of readable models to user. Every array element
-- is an object with fields "name" and "title". In transparent mode,
-- serve all models.
-- 
-- TODO: Cache this.
listModels :: Handler b (Redson b) ()
listModels = ifTop $ do
  au <- withAuth currentUser
  trs <- gets transparent
  readables <- case trs of
    True -> gets (M.toList . models)
    False ->
      case au of
        -- Won't get to serving [] anyways.
        Nothing -> handleError unauthorized >> return []
        -- Leave only readable models.
        Just user ->
            gets (filter (\(_, m) -> elem GET $
                                     getModelPermissions (Right user) m)
                  . M.toList . models)
  modifyResponse $ setContentType "application/json"
  writeLBS (A.encode $ 
             map (\(n, m) -> M.fromList $ 
                             [("name"::B.ByteString, n), 
                              ("title", title m)])
             readables)


defaultSearchLimit :: Int
defaultSearchLimit = 100


-----------------------------------------------------------------------------
-- | Serve model instances which have index values containing supplied
-- search parameters.
--
-- Currently not available in transparent mode.
search :: Handler b (Redson b) ()
search = 
    let
        intersectAll = foldl1' intersect
        unionAll = foldl1' union
        -- Fetch instance by id to JSON
        fetchInstance id key = runRedisDB database $ do
                                 Right r <- hgetall key
                                 return $ (M.fromList $ ("id", id):r)
        comma = 0x2c
    in
      ifTop $ withCheckSecurity $ \_ mdl -> do
        case mdl of
          Nothing -> handleError notFound
          Just m -> 
            let
                mname = modelName m
            in do
              -- TODO: Mark these field names as reserved
              mType <- getParam "_matchType"
              sType <- getParam "_searchType"
              outFields <- (\p -> maybe [] (B.split comma) p) <$>
                           getParam "_fields"

              patFunction <- return $ case mType of
                               Just "p"  -> prefixMatch
                               Just "s"  -> substringMatch
                               _         -> prefixMatch

              searchType  <- return $ case sType of
                               Just "and" -> intersectAll
                               Just "or"  -> unionAll
                               _          -> intersectAll

              itemLimit   <- fromIntParam "_limit" defaultSearchLimit

              -- Produce Just SearchTerm
              indexValues <- mapM (\(i, c) -> do
                                     p <- getParam i
                                     case p of
                                       Nothing -> return Nothing
                                       Just s -> if c then return $
                                                  Just (i, CRUD.collate s)
                                                 else return $
                                                  Just (i, s))
                             (indices m)

              -- For every term, get list of ids which match it
              termIds <- runRedisDB database $
                         redisSearch m (catMaybes indexValues) patFunction

              modifyResponse $ setContentType "application/json"
              case (filter (not . null) termIds) of
                [] -> writeLBS $ A.encode ([] :: [Value])
                tids -> do
                      -- Finally, list of matched instances
                      instances <- take itemLimit <$> 
                                   mapM (\id -> fetchInstance id $
                                         CRUD.instanceKey mname id)
                                  (searchType tids)
                      -- If _fields provided, leave only requested
                      -- fields and serve array of arrays. Otherwise,
                      -- serve array of objects.
                      case outFields of
                        [] -> writeLBS $ A.encode instances
                        _ -> writeLBS $ A.encode $
                             map (flip CRUD.onlyFields outFields) instances
              return ()


-----------------------------------------------------------------------------
-- | CRUD routes for models.
routes :: [(B.ByteString, Handler b (Redson b) ())]
routes = [ (":model/timeline", method GET timeline)
         , (":model/events", modelEvents)
         , (":model/model", method GET metamodel)
         , ("_models", method GET listModels)
         , (":model", method POST post)
         , (":model/:id", method GET read')
         , (":model/:id", method PUT put)
         , (":model/:id", method DELETE delete)
         , (":model/search/", method GET search)
         ]


------------------------------------------------------------------------------
-- | Initialize Redson. AuthManager from parent snaplet is required.
--
-- Connect to Redis, read configuration and set routes.
--
-- > appInit :: SnapletInit MyApp MyApp
-- > appInit = makeSnaplet "app" "App with Redson" Nothing $
-- >           do
-- >             r <- nestSnaplet "_" redson $ redsonInit auth
-- >             s <- nestSnaplet "session" session $ initCookieSessionManager
-- >                                                  sesKey "_session" sessionTimeout
-- >             a <- nestSnaplet "auth" auth $ initJsonFileAuthManager defAuthSettings
-- >             return $ MyApp r s a
redsonInit :: Lens b (Snaplet (AuthManager b))
           -> SnapletInit b (Redson b)
redsonInit topAuth = makeSnaplet
                     "redson"
                     "CRUD for JSON data with Redis storage"
                     Nothing $
          do
            r <- nestSnaplet "db" database $ redisDBInit defaultConnectInfo
            p <- liftIO PS.newPubSub

            cfg <- getSnapletUserConfig
            mdlDir <- liftIO $
                      lookupDefault "resources/models/"
                                    cfg "models-directory"

            transp <- liftIO $
                      lookupDefault False
                                    cfg "transparent-mode"

            grpDef <- liftIO $
                      lookupDefault "resources/field-groups.json"
                                    cfg "field-groups-file"

            mdls <- liftIO $ loadModels mdlDir grpDef
            addRoutes routes
            return $ Redson r topAuth p mdls transp