    {-# LANGUAGE OverloadedStrings #-}
    module Web.Simple.Static where

    import Control.Monad
    import Control.Monad.IO.Class
    import qualified Data.Text as T
    import Network.Wai
    import Network.HTTP.Types
    import Network.Mime
    import Web.Simple.Controller
    import System.Directory
    import System.FilePath

    serveStatic :: FilePath -> Controller a ()
    serveStatic :: FilePath -> Controller a ()
    serveStatic baseDir :: FilePath
    baseDir = do
      Request
    req <- Controller a Request
    forall s. Controller s Request
    request
      let fp :: FilePath
    fp = (FilePath -> FilePath -> FilePath)
    -> FilePath -> [FilePath] -> FilePath
    forall (t :: * -> *) b a.
    Foldable t =>
    (b -> a -> b) -> b -> t a -> b
    foldl FilePath -> FilePath -> FilePath
    (</>) FilePath
    baseDir ((Text -> FilePath) -> [Text] -> [FilePath]
    forall a b. (a -> b) -> [a] -> [b]
    map Text -> FilePath
    T.unpack ([Text] -> [FilePath]) -> [Text] -> [FilePath]
    forall a b. (a -> b) -> a -> b
    $ Request -> [Text]
    pathInfo Request
    req)
      Bool
    exists <- IO Bool -> ControllerT a IO Bool
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
    liftIO (IO Bool -> ControllerT a IO Bool)
    -> IO Bool -> ControllerT a IO Bool
    forall a b. (a -> b) -> a -> b
    $ FilePath -> IO Bool
    doesFileExist FilePath
    fp
      Bool -> Controller a () -> Controller a ()
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
    when Bool
    exists (Controller a () -> Controller a ())
    -> Controller a () -> Controller a ()
    forall a b. (a -> b) -> a -> b
    $ do
        Response -> Controller a ()
    forall s a. Response -> Controller s a
    respond (Response -> Controller a ()) -> Response -> Controller a ()
    forall a b. (a -> b) -> a -> b
    $ Status -> ResponseHeaders -> FilePath -> Maybe FilePart -> Response
    responseFile Status
    status200
          [(HeaderName
    hContentType, Text -> MimeType
    defaultMimeLookup (Text -> MimeType) -> Text -> MimeType
    forall a b. (a -> b) -> a -> b
    $ FilePath -> Text
    T.pack (FilePath -> Text) -> FilePath -> Text
    forall a b. (a -> b) -> a -> b
    $ FilePath -> FilePath
    takeFileName FilePath
    fp)]
          FilePath
    fp Maybe FilePart
    forall a. Maybe a
    Nothing
      Bool -> Controller a () -> Controller a ()
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
    when (FilePath -> Bool
    forall (t :: * -> *) a. Foldable t => t a -> Bool
    null (FilePath -> Bool) -> FilePath -> Bool
    forall a b. (a -> b) -> a -> b
    $ FilePath -> FilePath
    takeExtension FilePath
    fp) (Controller a () -> Controller a ())
    -> Controller a () -> Controller a ()
    forall a b. (a -> b) -> a -> b
    $ do
        let fpIdx :: FilePath
    fpIdx = FilePath
    fp FilePath -> FilePath -> FilePath
    </> "index.html"
        Bool
    existsIdx <- IO Bool -> ControllerT a IO Bool
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
    liftIO (IO Bool -> ControllerT a IO Bool)
    -> IO Bool -> ControllerT a IO Bool
    forall a b. (a -> b) -> a -> b
    $ FilePath -> IO Bool
    doesFileExist FilePath
    fpIdx
        Bool -> Controller a () -> Controller a ()
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
    when Bool
    existsIdx (Controller a () -> Controller a ())
    -> Controller a () -> Controller a ()
    forall a b. (a -> b) -> a -> b
    $ do
          Response -> Controller a ()
    forall s a. Response -> Controller s a
    respond (Response -> Controller a ()) -> Response -> Controller a ()
    forall a b. (a -> b) -> a -> b
    $ Status -> ResponseHeaders -> FilePath -> Maybe FilePart -> Response
    responseFile Status
    status200
            [(HeaderName
    hContentType, "text/html")]
            FilePath
    fpIdx Maybe FilePart
    forall a. Maybe a
    Nothing