Liaison.hs

module Network.Orchid.Core.Liaison (
    hWikiRetrieve
  , hWikiDeleteOrRename
  , hWikiStore
  , hWikiSearch
  ) where

import Control.Applicative ((<$>))
import Control.Exception.Extensible (try)
import Control.Monad.State (gets, lift)
import Data.Encoding (encodeLazyByteString)
import Data.Encoding.UTF8 (UTF8 (..))
import Data.FileStore hiding (NotFound)
import Data.List (find, intercalate)
import Data.Record.Label
import Network.Orchid.Core.Format (WikiFormat (..), Output (..))
import Network.Orchid.FormatRegister
import Network.Protocol.Http
import Network.Protocol.Uri
import Network.Salvia.Handler.Error (safeIO, hError, hCustomError)
import Network.Salvia.Handler.File ()
import Network.Salvia.Handler.Login (User, username, email)
import Network.Salvia.Handler.MethodRouter ()
import Network.Salvia.Handler.PathRouter ()
import Network.Salvia.Httpd (Handler, UriHandler, sendBs, sendStr, request, response, contentsUtf8, uriEncodedPostParamsUTF8)
import Misc.Commons (safeRead)
import qualified Data.ByteString.Lazy as B

-------- showing wiki documents -----------------------------------------------

{- |
Dependent on the `b' flag we either bounce the PUTted contents back in the
requested format, or we open the source version of the requested resource and
print this back in the requested format.
-}

hWikiRetrieve :: FileStore -> FilePath -> Bool -> UriHandler ()
hWikiRetrieve filestore workDir b u = do

  -- Fetch revision identifier from URI query string and convert this to a
  -- Maybe based on string-emptyness.
  let rev = lget query u
      revId = if null rev then Nothing else Just rev

  -- Compute the source file and format handler.
  let src = mkPathRelative $ lset extension Nothing $ lget path u
      ext = maybe "txt" id $ lget (extension % path) u
      fmt = maybe defaultFormat id $ find ((ext==) . postfix) wikiFormats

  -- The body might be retrieved from our filestore or from the request itself.
  body <- if b
    then contentsUtf8
    else lift (
          either (\e -> const Nothing (e::FileStoreError)) Just 
      <$> try (smartRetrieve filestore False src revId))

  -- Format the body using the selected wiki handler or return an error when
  -- the body could not be retrieved.
  case body of
    Nothing -> hError NotFound
    Just s -> do
      b <- lift $ (handler fmt) filestore workDir src s
      (body, enc) <- return $ case b of
        TextOutput   s  -> (encodeLazyByteString UTF8 s, Just utf8)
        BinaryOutput bs -> (bs, Nothing)

      enterM response $ do
        setM status OK
        setM contentType   (mime fmt, enc)
        setM contentLength (Just $ fromIntegral $ B.length body)
      sendBs body

-------- deleting wiki documents ----------------------------------------------

-- TODO:generalize deletion/storage

hWikiDeleteOrRename :: FileStore -> User -> UriHandler ()
hWikiDeleteOrRename filestore user u = do

  let rev = lget query u

  if null rev
    then hCustomError BadRequest errEmptyRev
    else do
      mdoc <- contentsUtf8
      let aut = Author (username user) (email user)
          src = mkPathRelative $ lset extension Nothing $ lget path u
      lift $ case mdoc of
        Nothing -> delete filestore src    aut rev
        Just mv -> rename filestore src mv aut rev

errEmptyRev, errEmptyRes :: String
errEmptyRev = "empty revision name not allowed"
errEmptyRes = "empty resource name not allowed"

-------- storing wiki documents -----------------------------------------------

hWikiStore :: FileStore -> User -> UriHandler ()
hWikiStore filestore user u = do

  let rev = lget query u
  mdoc <- contentsUtf8
  case (null rev, mdoc) of

    -- Error cases.
    (True,  Nothing) -> hCustomError BadRequest (errEmptyRev ++ "\n" ++ errEmptyRes)
    (True,  Just _)  -> hCustomError BadRequest errEmptyRev
    (False, Nothing) -> hCustomError BadRequest errEmptyRes

    (False, Just doc) -> lift $ do
      let aut = Author (username user) (email user)
          src = mkPathRelative $ lset extension Nothing $ lget path u
      save filestore src aut rev doc

-------- searching wiki documents ---------------------------------------------

hWikiSearch :: FileStore -> Handler ()
hWikiSearch filestore = do

  params <- uriEncodedPostParamsUTF8

  case getSearchInfo params of
    Nothing -> hCustomError BadRequest "no search query specified"
    Just (a, b, c, d) -> do
      res <- lift $ search filestore (SearchQuery [a] b c d)
      enterM response $ do
        setM status OK
        setM contentType ("text/plain", Just utf8)
      sendStr (intercalate "\n\n" $ map showMatch res)

getSearchInfo :: Maybe Parameters -> Maybe (String, Bool, Bool, Bool)
getSearchInfo params = do
  p <- params
  patterns   <- "patterns"   `lookup` p >>= id
  wholewords <- "wholewords" `lookup` p >>= id >>= safeRead
  matchall   <- "matchall"   `lookup` p >>= id >>= safeRead
  ignorecase <- "ignorecase" `lookup` p >>= id >>= safeRead
  return (patterns, wholewords, matchall, ignorecase)

showMatch :: SearchMatch -> String
showMatch match =
    intercalate "\n"
  $ map (\(a, b) -> a ++ "=" ++ b match) [
      ("resource",    matchResourceName)
    , ("linenumber",  show . matchLineNumber)
    , ("line",        matchLine)
    ]