module Rakka.Resource
    ( runIdempotentA
    , 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           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


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