{-# LANGUAGE
    Arrows
  , DoAndIfThenElse
  , UnicodeSyntax
  #-}
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.Arrow.ListArrow
import Control.Arrow.Unicode
import           Control.Monad
import           Control.Monad.Trans
import Data.Monoid.Unicode
import qualified Data.Text as T
import           Network.HTTP.Lucu
import           Network.HTTP.Lucu.Utils
import           Network.URI hiding (path)
import Prelude.Unicode
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.DOM.TypeDefs
import Text.XML.HXT.Arrow.XmlState

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 ∷ FilePath → IOSArrow XmlTree (Resource c) → Resource c
runXmlA schemaPath a
    = do inputA ← getInputXmlA 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 ∷ FilePath → Resource (IOSArrow b XmlTree)
getInputXmlA schemaPath
    = do reader    ← getInputReader
         validator ← getValidator 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 [ withValidate        no
                                   , withCheckNamespaces yes
                                   , withRemoveWS        yes
                                   ] (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
                              [ withIndent yes
                              , withXmlPi  yes
                              ]
                            )
         output $ UTF8.encodeString 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" [])
         let [xmlStr] = runLA ( writeDocumentToString
                                [ withIndent yes
                                , withXmlPi  yes
                                ]
                              ) tree
         output $ UTF8.encodeString xmlStr

getUserID ∷ Environment → Resource (Maybe String)
getUserID env
    = do auth ← getAuthorization
         case auth of
           Just (BasicAuthCredential userID password)
               → do valid ← isValidPair (envAuthDB env)
                                        (T.pack userID)
                                        (T.pack password)
                    if valid then
                        return (Just userID)
                    else
                        return Nothing
           _   → return Nothing