{-# 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.Fix
import Control.Monad.IO.Class
import Control.Monad.Reader (ReaderT, runReaderT, ask)
import Control.Monad.Unicode
import Data.Ascii (Ascii, CIAscii, AsciiBuilder)
import Data.ByteString (ByteString)
import qualified Data.ByteString as BS
import Data.Collections
import Data.Convertible.Base
import Data.Convertible.Instances.Text ()
import Data.List (intersperse, nub)
import Data.Maybe
import Data.Monoid
import Data.Monoid.Unicode
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.Response.StatusCode
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, MonadFix, 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"
                          $ cs
                          $ mconcat
                          $ intersperse (cs (", " ∷ Ascii) ∷ AsciiBuilder)
                          $ map cs allowedMethods

      allowedMethods ∷ [Ascii]
      allowedMethods = nub $ concat [ methods resGet    ["GET", "HEAD"]
                                    , methods resHead   ["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 $ cs $ 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.withSocketsDo' '.' '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 reqHasBody 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 ()