{-# LANGUAGE
    CPP
  , DoAndIfThenElse
  , FlexibleInstances
  , GeneralizedNewtypeDeriving
  , OverloadedStrings
  , MultiParamTypeClasses
  , RecordWildCards
  , UnicodeSyntax
  #-}
module Network.HTTP.Lucu.Resource.Internal
    ( Rsrc
    , Resource(..)
    , spawnRsrc

    , getConfig
    , getRemoteAddr
#if defined(HAVE_SSL)
    , getRemoteCertificate
#endif
    , getRequest
    , getResourcePath

    , getChunk

    , setStatus
    , setHeader
    , deleteHeader

    , putBuilder

    , driftTo
    )
    where
import Blaze.ByteString.Builder (Builder)
import Control.Applicative
import Control.Concurrent
import Control.Concurrent.STM
import Control.Exception
import Control.Monad hiding (mapM_)
import Control.Monad.IO.Class
import Control.Monad.Reader (ReaderT, runReaderT, ask)
import Control.Monad.Unicode
import Data.Ascii (Ascii, CIAscii)
import qualified Data.Ascii as A
import Data.ByteString (ByteString)
import qualified Data.ByteString as BS
import Data.Collections
import Data.List (intersperse, nub)
import Data.Maybe
import Data.Monoid
import Data.Monoid.Unicode
import qualified Data.Text as T
import Network.HTTP.Lucu.Abortion
import Network.HTTP.Lucu.Abortion.Internal
import Network.HTTP.Lucu.Config
import Network.HTTP.Lucu.DefaultPage
import qualified Network.HTTP.Lucu.Headers as H
import Network.HTTP.Lucu.Interaction
import Network.HTTP.Lucu.Postprocess
import Network.HTTP.Lucu.Request
import Network.HTTP.Lucu.Response
import Network.HTTP.Lucu.Utils
import Network.Socket
#if defined(HAVE_SSL)
import OpenSSL.X509
#endif
import Prelude hiding (catch, concat, filter, mapM_, tail)
import Prelude.Unicode
import System.IO

-- |The resource monad. This monad implements 'MonadIO' so it can do
-- any 'IO' actions.
newtype Rsrc a
    = Rsrc {
        unRsrc ∷ ReaderT NormalInteraction IO a
      }
    deriving (Applicative, Functor, Monad, MonadIO)

runRsrc ∷ Rsrc a → NormalInteraction → IO a
runRsrc = runReaderT ∘ unRsrc

-- |'Resource' is basically a set of 'Rsrc' monadic computations for
-- each HTTP methods.
data Resource = Resource {
    -- |A 'Rsrc' to be run when a GET request comes for the
    -- resource path. If 'resGet' is Nothing, the system responds
    -- \"405 Method Not Allowed\" for GET requests.
    --
    -- It also runs for HEAD request if the 'resHead' is 'Nothing'. In
    -- that case 'putChunk' and such don't actually write a response
    -- body.
      resGet              ∷ !(Maybe (Rsrc ()))
    -- |A 'Rsrc' to be run when a HEAD request comes for the
    -- resource path. If 'resHead' is Nothing, the system runs
    -- 'resGet' instead. If 'resGet' is also Nothing, the system
    -- responds \"405 Method Not Allowed\" for HEAD requests.
    , resHead             ∷ !(Maybe (Rsrc ()))
    -- |A 'Rsrc' to be run when a POST request comes for the
    -- resource path. If 'resPost' is Nothing, the system responds
    -- \"405 Method Not Allowed\" for POST requests.
    , resPost             ∷ !(Maybe (Rsrc ()))
    -- |A 'Rsrc' to be run when a PUT request comes for the
    -- resource path. If 'resPut' is Nothing, the system responds
    -- \"405 Method Not Allowed\" for PUT requests.
    , resPut              ∷ !(Maybe (Rsrc ()))
    -- |A 'Rsrc' to be run when a DELETE request comes for the
    -- resource path. If 'resDelete' is Nothing, the system responds
    -- \"405 Method Not Allowed\" for DELETE requests.
    , resDelete           ∷ !(Maybe (Rsrc ()))
    }

instance Monoid Resource where
    {-# INLINE mempty #-}
    mempty
        = Resource {
            resGet    = Nothing
          , resHead   = Nothing
          , resPost   = Nothing
          , resPut    = Nothing
          , resDelete = Nothing
          }
    {-# INLINEABLE mappend #-}
    mappend a b
        = Resource {
            resGet    = resGet    a <|> resGet    b
          , resHead   = resHead   a <|> resHead   b
          , resPost   = resPost   a <|> resPost   b
          , resPut    = resPut    a <|> resPut    b
          , resDelete = resDelete a <|> resDelete b
          }

instance Unfoldable Resource (Method, Rsrc ()) where
    {-# INLINEABLE insert #-}
    insert (GET   , a) r = r { resGet    = Just a }
    insert (HEAD  , a) r = r { resHead   = Just a }
    insert (POST  , a) r = r { resPost   = Just a }
    insert (PUT   , a) r = r { resPut    = Just a }
    insert (DELETE, a) r = r { resDelete = Just a }
    insert _           r = r
    {-# INLINE empty #-}
    empty = (∅)

instance Foldable Resource (Method, Rsrc ()) where
    {-# INLINEABLE foldMap #-}
    foldMap f (Resource {..})
        = maybe (∅) (f ∘ ((,) GET   )) resGet  ⊕
          maybe (∅) (f ∘ ((,) HEAD  )) resHead ⊕
          maybe (∅) (f ∘ ((,) POST  )) resPost ⊕
          maybe (∅) (f ∘ ((,) PUT   )) resPut  ⊕
          maybe (∅) (f ∘ ((,) DELETE)) resDelete

instance Collection Resource (Method, Rsrc ()) where
    {-# INLINE filter #-}
    filter = (fromList ∘) ∘ (∘ fromFoldable) ∘ filter

spawnRsrc ∷ Resource → NormalInteraction → IO ThreadId
spawnRsrc (Resource {..}) ni@(NI {..})
    = forkIO $ run `catch` processException
    where
      run ∷ IO ()
      run = flip runRsrc ni $
            do req ← getRequest
               fromMaybe notAllowed $ rsrc req
               driftTo Done

      rsrc ∷ Request → Maybe (Rsrc ())
      rsrc req
          = case reqMethod req of
              GET    → resGet
              HEAD   → case resHead of
                          Just r  → Just r
                          Nothing → resGet
              POST   → resPost
              PUT    → resPut
              DELETE → resDelete
              _      → error $ "Unknown request method: " ⧺ show (reqMethod req)

      notAllowed ∷ Rsrc ()
      notAllowed = do setStatus MethodNotAllowed
                      setHeader "Allow"
                          $ A.fromAsciiBuilder
                          $ mconcat
                          $ intersperse (A.toAsciiBuilder ", ")
                          $ map A.toAsciiBuilder allowedMethods

      allowedMethods ∷ [Ascii]
      allowedMethods = nub $ concat [ methods resGet    ["GET"]
                                    , methods resHead   ["GET", "HEAD"]
                                    , methods resPost   ["POST"]
                                    , methods resPut    ["PUT"]
                                    , methods resDelete ["DELETE"]
                                    ]

      methods ∷ Maybe a → [Ascii] → [Ascii]
      methods m xs
          | isJust m  = xs
          | otherwise = []

      toAbortion ∷ SomeException → Abortion
      toAbortion e
          = case fromException e of
              Just abortion → abortion
              Nothing       → mkAbortion' InternalServerError $ T.pack $ show e

      processException ∷ SomeException → IO ()
      processException exc
          = do let abo = toAbortion exc
               state ← atomically $ readTVar niState
               res   ← atomically $ readTVar niResponse
               if state ≤ DecidingHeader then
                   -- We still have a chance to reflect this abortion
                   -- in the response. Hooray!
                   flip runRsrc ni $
                       do setStatus $ aboStatus abo
                          mapM_ (uncurry setHeader) (aboHeaders abo)
                          setHeader "Content-Type" defaultPageContentType
                          deleteHeader "Content-Encoding"
                          putBuilder $ abortPage niConfig (Just niRequest) res abo
               else
                   when (cnfDumpTooLateAbortionToStderr niConfig)
                       $ dumpAbortion abo
               runRsrc (driftTo Done) ni

dumpAbortion ∷ Abortion → IO ()
dumpAbortion abo
    = hPutStr stderr
      $ concat [ "Lucu: an exception occured after "
               , "sending the response header to the client:\n"
               , "  ", show abo, "\n"
               ]

getInteraction ∷ Rsrc NormalInteraction
getInteraction = Rsrc ask

-- |Get the 'Config' value for this httpd.
getConfig ∷ Rsrc Config
getConfig = niConfig <$> getInteraction

-- |Get the 'SockAddr' of the remote host.
getRemoteAddr ∷ Rsrc SockAddr
getRemoteAddr = niRemoteAddr <$> getInteraction

#if defined(HAVE_SSL)
-- | Return the X.509 certificate of the client, or 'Nothing' if:
--
--   * This request didn't came through an SSL stream.
--
--   * The client didn't send us its certificate.
--
--   * The 'OpenSSL.Session.VerificationMode' of
--   'OpenSSL.Session.SSLContext' in 'SSLConfig' has not been set to
--   'OpenSSL.Session.VerifyPeer'.
getRemoteCertificate ∷ Rsrc (Maybe X509)
getRemoteCertificate = niRemoteCert <$> getInteraction
#endif

-- |Return the 'Request' value representing the request header. You
-- usually don't need to call this function directly.
getRequest ∷ Rsrc Request
getRequest = niRequest <$> getInteraction

-- |Get the path of this 'Rsrc' (to be exact, 'Resource') in the
-- corresponding 'Network.HTTP.Lucu.ResourceTree'. The result of this
-- action is the exact path in the tree even when the 'Resource' is
-- 'Network.HTTP.Lucu.greedy'.
--
-- Example:
--
-- @
--   main :: 'IO' ()
--   main = let tree :: 'Network.HTTP.Lucu.ResourceTree'
--              tree = 'fromList' [ (["foo"], 'Network.HTTP.Lucu.greedy' resFoo) ]
--          in 'Network.HTTP.Lucu.runHttpd' 'defaultConfig' $ 'Network.HTTP.Lucu.resourceMap' tree
--
--   resFoo :: 'Resource'
--   resFoo = 'singleton'
--            ( 'GET'
--            , do requestURI   <- 'getRequestURI'
--                 resourcePath <- 'getResourcePath'
--                 pathInfo     <- 'getPathInfo'
--                 -- 'Network.URI.uriPath' requestURI '==' \"/foo/bar/baz\"
--                 -- resourcePath       == ["foo"]
--                 -- pathInfo           == ["bar", "baz"]
--                 ...
--            )
-- @
getResourcePath ∷ Rsrc Path
getResourcePath = niResourcePath <$> getInteraction

-- |@'getChunk' n@ attempts to read a chunk of request body up to @n@
-- bytes. You can incrementally read the request body by repeatedly
-- calling this function. If there is nothing to be read anymore,
-- 'getChunk' returns 'BS.empty' and makes 'Rsrc' transit to the
-- /Deciding Header/ state.
getChunk ∷ Int → Rsrc ByteString
getChunk = (driftTo ReceivingBody *>) ∘ getChunk'

getChunk' ∷ Int → Rsrc ByteString
getChunk' n
    | n < 0     = fail ("getChunk: n must not be negative: " ⧺ show n)
    | n ≡ 0     = return (∅)
    | otherwise = do req ← getRequest
                     if reqMustHaveBody req then
                         askForInput =≪ getInteraction
                     else
                         driftTo DecidingHeader *> return (∅)
    where
      askForInput ∷ NormalInteraction → Rsrc ByteString
      askForInput (NI {..})
          = do -- Ask the RequestReader to get a chunk.
               liftIO $ atomically
                      $ putTMVar niReceiveBodyReq (ReceiveBody n)
               -- Then wait for a reply.
               chunk ← liftIO
                       $ atomically
                       $ takeTMVar niReceivedBody
               -- Have we got an EOF?
               when (BS.null chunk)
                   $ driftTo DecidingHeader
               return chunk

-- |Declare the response status code. If you don't call this function,
-- the status code will be defaulted to \"200 OK\".
setStatus ∷ StatusCode sc ⇒ sc → Rsrc ()
setStatus sc
    = do ni ← getInteraction
         liftIO $ atomically
                $ do state ← readTVar $ niState ni
                     when (state > DecidingHeader)
                         $ fail "Too late to declare the response status."
                     res ← readTVar $ niResponse ni
                     writeTVar (niResponse ni) $ setStatusCode sc res

-- |@'setHeader' name value@ declares the value of the response header
-- @name@ as @value@. Note that this function is not intended to be
-- used so frequently: there should be specialised functions like
-- 'Network.HTTP.Lucu.setContentType' for every common headers.
--
-- Some important headers (especially \"Content-Length\" and
-- \"Transfer-Encoding\") may be silently dropped or overwritten by
-- the system not to corrupt the interaction with client at the
-- viewpoint of HTTP protocol layer. For instance, if we are keeping
-- the connection alive, without this manipulation it will be a
-- catastrophe when we send a header \"Content-Length: 10\" and
-- actually send a body of 20 bytes long to the remote peer. In this
-- case the client shall only accept the first 10 bytes of response
-- body and thinks that the residual 10 bytes is a part of the header
-- of the next response.
setHeader ∷ CIAscii → Ascii → Rsrc ()
setHeader name value = liftIO ∘ atomically ∘ go =≪ getInteraction
    where
      go ∷ NormalInteraction → STM ()
      go (NI {..})
          = do state ← readTVar niState
               when (state > DecidingHeader) $
                   fail "Too late to declare a response header field."
               res ← readTVar niResponse
               writeTVar niResponse $ H.setHeader name value res
               when (name ≡ "Content-Type") $
                   writeTVar niResponseHasCType True

-- |@'deleteHeader' name@ deletes a response header @name@ if
-- any. This function is not intended to be used so frequently.
deleteHeader ∷ CIAscii → Rsrc ()
deleteHeader name = liftIO ∘ atomically ∘ go =≪ getInteraction
    where
      go ∷ NormalInteraction → STM ()
      go (NI {..})
          = do state ← readTVar niState
               when (state > DecidingHeader) $
                   fail "Too late to delete a response header field."
               res ← readTVar niResponse
               writeTVar niResponse $ H.deleteHeader name res
               when (name ≡ "Content-Type") $
                   writeTVar niResponseHasCType False

-- |Run a 'Builder' to construct a chunk, and write it to the response
-- body. It can be safely applied to a 'Builder' producing an
-- infinitely long stream of octets.
--
-- Note that you must first declare the response header
-- \"Content-Type\" before applying this function. See
-- 'Network.HTTP.Lucu.setContentType'.
putBuilder ∷ Builder → Rsrc ()
putBuilder b = liftIO ∘ atomically ∘ go =≪ getInteraction
    where
      -- FIXME: should see if resCanHaveBody.
      go ∷ NormalInteraction → STM ()
      go ni@(NI {..})
          = do driftTo' ni SendingBody
               hasCType ← readTVar niResponseHasCType
               unless hasCType
                   $ throwSTM
                   $ mkAbortion' InternalServerError
                     "putBuilder: Content-Type has not been set."
               putTMVar niBodyToSend b

driftTo ∷ InteractionState → Rsrc ()
driftTo = (getInteraction ≫=) ∘ ((liftIO ∘ atomically) ∘) ∘ flip driftTo'

driftTo' ∷ NormalInteraction → InteractionState → STM ()
driftTo' ni@(NI {..}) newState
    = do oldState ← readTVar niState
         driftFrom oldState
    where
      driftFrom ∷ InteractionState → STM ()
      driftFrom oldState
          | newState < oldState = throwStateError oldState newState
          | newState ≡ oldState = return ()
          | otherwise
              = do let a = [oldState .. newState]
                       b = tail a
                       c = zip a b
                   mapM_ (uncurry driftFromTo) c
                   writeTVar niState newState

      throwStateError ∷ Monad m ⇒ InteractionState → InteractionState → m a
      throwStateError Done SendingBody
          = fail "It makes no sense to output something after finishing outputs."
      throwStateError old new
          = fail ("State error: " ⧺ show old ⧺ " ==> " ⧺ show new)

      driftFromTo ∷ InteractionState → InteractionState → STM ()
      driftFromTo ReceivingBody _
          = putTMVar niReceiveBodyReq WasteAll
      driftFromTo DecidingHeader _
          = postprocess ni
      driftFromTo _ _
          = return ()