module Rakka.Resource
    ( runIdempotentA
    , runXmlA
    , outputXmlPage
    )
    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.Environment
import           Rakka.Validation
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


-- "/"         ==> "/"
-- "/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
               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")
               , ( "xml", read "text/xml"             )
               ]


outputXmlPage :: XmlTree -> IOSArrow XmlTree XmlTree -> Resource ()
outputXmlPage tree toXHTML
    = do mType <- getEntityType
         setContentType mType
         let formatter = case mType of
                           MIMEType "application" "xhtml+xml" _ -> toXHTML
                           MIMEType "text"        "xml"       _ -> this
                           _                                    -> undefined
         [resultStr] <- liftIO $ runX ( setErrorMsgHandler False fail
                                        >>>
                                        constA tree
                                        >>>
                                        formatter
                                        >>>
                                        writeDocumentToString [ (a_indent, v_1) ]
                                      )
         output resultStr