{-# LANGUAGE
    DoAndIfThenElse
  , OverloadedStrings
  , QuasiQuotes
  , UnicodeSyntax
  #-}
-- | Handling static files on the filesystem.
module Network.HTTP.Lucu.StaticFile
    ( staticFile
    , staticDir
    )
    where
import Control.Monad
import Control.Monad.Unicode
import Control.Monad.Trans
import Data.ByteString (ByteString)
import qualified Data.ByteString.Lazy.Char8 as LBS
import Data.Convertible.Base
import Data.Convertible.Instances.Text ()
import Data.Monoid.Unicode
import Data.String
import qualified Data.Text.Encoding as T
import Network.HTTP.Lucu.Abortion
import Network.HTTP.Lucu.Config
import Network.HTTP.Lucu.MIMEType
import Network.HTTP.Lucu.MIMEType.Guess
import Network.HTTP.Lucu.Resource
import Network.HTTP.Lucu.Resource.Internal
import Network.HTTP.Lucu.Response
import Network.HTTP.Lucu.Utils
import Prelude.Unicode
import System.Directory
import System.FilePath

-- | @'staticFile' fpath@ is a 'Resource' which serves the file at
-- @fpath@ on the filesystem.
staticFile ∷ FilePath → Resource
staticFile path
    = (∅) {
        resGet  = Just $ handleStaticFile True  path
      , resHead = Just $ handleStaticFile False path
      }

octetStream ∷ MIMEType
octetStream = [mimeType| application/octet-stream |]

handleStaticFile ∷ Bool → FilePath → Rsrc ()
handleStaticFile sendContent path
    = do isDir ← liftIO $ doesDirectoryExist path
         when isDir
             $ abort
             $ mkAbortion Forbidden [] Nothing

         isFile ← liftIO $ doesFileExist path
         unless isFile
             foundNoEntity'

         perms ← liftIO $ getPermissions path
         unless (readable perms)
             $ abort
             $ mkAbortion Forbidden [] Nothing

         lastMod ← liftIO $ getLastModified path
         foundTimeStamp lastMod

         conf ← getConfig
         case guessTypeByFileName (cnfExtToMIMEType conf) path of
           Nothing   → setContentType octetStream
           Just mime → setContentType mime

         when sendContent
             $ liftIO (LBS.readFile path) ≫= putChunks

-- | @'staticDir' dir@ is a 'Resource' which maps all files in @dir@
-- and its subdirectories on the filesystem to the resource tree. Thus
-- having 'Network.HTTP.Lucu.nonGreedy' 'staticDir' in a tree makes no
-- sense.
--
-- Note that 'staticDir' currently doesn't have a directory-listing
-- capability. Requesting the content of a directory will end up being
-- replied with /403 Forbidden/.
staticDir ∷ FilePath → Resource
staticDir path
    = (∅) {
        resGet  = Just $ handleStaticDir True  path
      , resHead = Just $ handleStaticDir False path
      }

-- TODO: implement directory listing.
handleStaticDir ∷ Bool → FilePath → Rsrc ()
handleStaticDir sendContent basePath
    = do extraPath ← getPathInfo
         securityCheck extraPath
         let path = basePath </> joinPath (map dec8 extraPath)
         handleStaticFile sendContent path
    where
      dec8 ∷ ByteString → String
      dec8 = cs ∘ T.decodeUtf8

securityCheck ∷ (Eq s, Show s, IsString s, Monad m) ⇒ [s] → m ()
securityCheck pathElems
    = when (any (≡ "..") pathElems)
          $ fail ("security error: " ⧺ show pathElems)