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

import qualified Codec.Binary.UTF8.String as UTF8
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.FilePath.Posix
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 :: URI -> Resource ()
canonicalizeURI baseURI
    = do rPath <- return . uriPath =<< getRequestURI
         let newURI   = baseURI { uriPath = uriPath baseURI </> newPath }
             newPath  = foldl (</>) "/" newPath'
             newPath' = case [x | x <- splitBy (== '/') rPath, x /= ""] of
                          []   -> []
                          path -> case break (== '.') $ last path of
                                    (_, "") -> let basePieces = reverse $ tail $ reverse path
                                                   lastPiece  = last path
                                               in
                                                 basePieces ++ [lastPiece ++ ".html"]
                                    (_, _)  -> path
         when (rPath /= newPath)
              $ abort MovedPermanently
                [("Location", uriToString id newURI $ "")]
                Nothing


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


runIdempotentA' :: IOSArrow () (Resource c) -> Resource c
runIdempotentA' a
    = do [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)
                                   ] (UTF8.decodeString 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)]


outputXml :: XmlTree -> Resource ()
outputXml tree
    = do setContentType (MIMEType "text" "xml" [])
         [xmlStr] <- liftIO $ runX ( setErrorMsgHandler False fail
				     >>>
				     constA tree
				     >>>
				     writeDocumentToString [ (a_indent, v_1) ]
				   )
	 output xmlStr


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