module Rakka.Resource
    ( runIdempotentA
    , runXmlA
    , getEntityType
    , outputXmlPage
    , outputXmlPage'
    , getUserID
    )
    where

import           Control.Arrow
import           Control.Arrow.ArrowList
import           Control.Monad
import           Control.Monad.Trans
import           Network.HTTP.Lucu
import           Network.HTTP.Lucu.Utils
import           Network.URI hiding (path)
import           Rakka.Authorization
import           Rakka.Environment
import           Rakka.Validation
import           System.Log.Logger
import           Text.XML.HXT.Arrow.ReadDocument
import           Text.XML.HXT.Arrow.WriteDocument
import           Text.XML.HXT.Arrow.XmlIOStateArrow
import           Text.XML.HXT.DOM.TypeDefs
import           Text.XML.HXT.DOM.XmlKeywords


logger :: String
logger = "Rakka.Resource"


-- "/"         ==> "/"
-- "/foo"      ==> "/foo.html"
-- "/foo/"     ==> "/foo.html"
-- "/foo.bar/" ==> "/foo.bar"
-- "/foo.bar"  ==> "/foo.bar"
canonicalizeURI :: Resource ()
canonicalizeURI 
    = do uri <- getRequestURI
         let newURI  = uri { uriPath = "/" ++ joinWith "/" newPath }
             newPath = case [x | x <- splitBy (== '/') (uriPath uri), x /= ""] of
                         []   -> []
                         path -> case break (== '.') $ last path of
                                   (_, "") -> let basePieces = reverse $ tail $ reverse path
                                                  lastPiece  = last path
                                              in
                                                basePieces ++ [lastPiece ++ ".html"]
                                   (_, _)  -> path
         when (uri /= newURI)
              $ abort MovedPermanently
                [("Location", uriToString id newURI $ "")]
                Nothing


runIdempotentA :: IOSArrow () (Resource c) -> Resource c
runIdempotentA a
    = do canonicalizeURI
         [rsrc] <- liftIO $ runX ( setErrorMsgHandler False fail
                                   >>>
                                   constA ()
                                   >>>
                                   a
                                 )
         rsrc


runXmlA :: Environment -> FilePath -> IOSArrow XmlTree (Resource c) -> Resource c
runXmlA env schemaPath a
    = do inputA <- getInputXmlA env schemaPath
         [rsrc] <- liftIO $ runX ( inputA
                                   >>>
                                   setErrorMsgHandler False fail
                                   >>>
                                   a
                                 )
         rsrc


-- well-formed でない時は 400 Bad Request になり、valid でない時は 422
-- Unprocessable Entity になる。入力の型が XML でない時は 415
-- Unsupported Media Type を返す。
getInputXmlA :: Environment -> FilePath -> Resource (IOSArrow b XmlTree)
getInputXmlA env schemaPath
    = do reader    <- getInputReader
         validator <- getValidator env schemaPath
         return ( setErrorMsgHandler False (abort BadRequest [] . Just)
                  >>>
                  reader
                  >>>
                  setErrorMsgHandler False (abort UnprocessableEntitiy [] . Just)
                  >>>
                  validator
                )


getInputReader :: Resource (IOSArrow b XmlTree)
getInputReader 
    = do mimeType <- getContentType
         case mimeType of
           Nothing
               -> getFailingReader BadRequest [] (Just "Missing Content-Type")
           Just (MIMEType "text" "xml" _)
               -> getXmlReader
           Just (MIMEType "application" "xml" _)
               -> getXmlReader
           Just t
               -> getFailingReader UnsupportedMediaType [] (Just $ "Unsupported media type: " ++ show t)
    where
      getXmlReader
          = do req <- input defaultLimit
               liftIO $ debugM logger req
               return $ readString [ (a_validate         , v_0)
                                   , (a_check_namespaces , v_1)
                                   , (a_remove_whitespace, v_0)
                                   ] req
      getFailingReader code headers msg
          = return $ proc _ -> abortA -< (code, (headers, msg))


getEntityType :: Resource MIMEType
getEntityType
    = do uri <- getRequestURI
         let ext = reverse $ takeWhile (/= '.') $ reverse $ uriPath uri
         case lookup ext extMap of
           Just mType -> return mType
           Nothing    -> abort NotFound [] (Just $ "Unsupported entity type: " ++ ext)
    where
      extMap :: [(String, MIMEType)]
      extMap = [ ("html", read "application/xhtml+xml")
               , ( "rdf", read "application/rss+xml"  )
               , ( "xml", read "text/xml"             )
               ]


outputXmlPage :: XmlTree -> [(MIMEType, IOSArrow XmlTree XmlTree)] -> Resource ()
outputXmlPage tree formatters
    = do mType <- getEntityType
         setContentType mType
         let formatter = case lookup mType formatters of
                           Just f  -> f
                           Nothing -> this
         [resultStr] <- liftIO $ runX ( setErrorMsgHandler False fail
                                        >>>
                                        constA tree
                                        >>>
                                        formatter
                                        >>>
                                        writeDocumentToString [ (a_indent, v_1) ]
                                      )
         output resultStr


outputXmlPage' :: XmlTree -> IOSArrow XmlTree XmlTree -> Resource ()
outputXmlPage' tree toXHTML
    = outputXmlPage tree [(MIMEType "application" "xhtml+xml" [], toXHTML)]


getUserID :: Environment -> Resource (Maybe String)
getUserID env
    = do auth <- getAuthorization
         case auth of
           Just (BasicAuthCredential userID password)
               -> do valid <- isValidPair (envAuthDB env) userID password
                     if valid then
                         return (Just userID)
                       else
                         return Nothing
           _   -> return Nothing