content: {-# LANGUAGE UndecidableInstances #-}
  
  -- | Server definition
  module Mig.Core.Server (
    Server (..),
    FindRoute (..),
    treeApiStrategy,
    plainApiStrategy,
    mapServerFun,
    mapResponse,
    fromServer,
    fromServerWithCache,
    fillCaptures,
    addTag,
    setDescription,
    setSummary,
    mapRouteInfo,
    staticFiles,
    describeInputs,
    atPath,
    filterPath,
    getServerPaths,
    addPathLink,
  ) where
  
  import Control.Applicative
  import Control.Monad
  import Control.Monad.IO.Class
  import Data.ByteString (ByteString)
  import Data.ByteString.Lazy qualified as BL
  import Data.List qualified as List
  import Data.Map.Strict (Map)
  import Data.Map.Strict qualified as Map
  import Data.Maybe
  import Data.String
  import Data.Text (Text)
  import Data.Text qualified as Text
  import Safe (atMay, headMay)
  import System.FilePath (takeExtension)
  import Web.HttpApiData
  
  import Mig.Core.Api (Api, fromNormalApi, toNormalApi)
  import Mig.Core.Api qualified as Api
  import Mig.Core.Api.NormalForm.TreeApi qualified as TreeApi
  import Mig.Core.Class.MediaType
  import Mig.Core.Class.Response (IsResp (..), Resp (..))
  import Mig.Core.Class.Route
  import Mig.Core.Server.Cache
  import Mig.Core.ServerFun (ServerFun)
  import Mig.Core.Types (Request (..), Response, setContent)
  import Mig.Core.Types.Info (RouteInfo (..), RouteInput (..), describeInfoInputs, setOutputMedia)
  import Mig.Core.Types.Info qualified as Describe (Describe (..))
  import Mig.Core.Types.Route
  
  {-| Server type. It is a function fron request to response.
  Some servers does not return valid value. We use it to find right path.
  
  Example:
  
  > server :: Server IO
  > server =
  >   "api/v1" /.
  >      [ "foo" /. handleFoo
  >      , "bar" /. handleBar
  >      ]
  >
  > handleFoo :: Query "name" Int -> Get IO (Resp Json Text)
  > handleBar :: Post Json IO Text
  
  Note that server is monoid and it can be constructed with Monoid functions and
  path constructor @(/.)@. To pass inputs for handler we can use special newtype wrappers:
  
  * @Query@ - for required query parameters
  * @Optional@ - for optional query parameters
  * @QueryFlag@ - for boolean query flags
  * @Capture@ - for parsing elements of URI
  * @Header@ - for parsing headers
  * @OptionalHeader@ - for parsing optional headers
  * @Body@ - fot request-body input
  
  and other request types.
  
  To distinguish by HTTP-method we use corresponding constructors: Get, Post, Put, etc.
  Let's discuss the structure of the constructor. Let's take Get for example:
  
  > type Get m a = Send GET m a
  > newtype Send method m a = Send (m a)
  
   Let's look at the arguments of he type
  
  * @method@ - type tag of the HTTP-method (GET, POST, PUT, DELETE, etc.)
  * @m@ - underlying server monad
  * @a@ - response type. It should be convertible to the type of the response (see @IsResp@ class).
  -}
  newtype Server m = Server {unServer :: Api (Route m)}
    deriving newtype (Semigroup, Monoid)
  
  -- | Applies server function to all routes
  mapServerFun :: (ServerFun m -> ServerFun n) -> Server m -> Server n
  mapServerFun f (Server server) = Server $ fmap (\x -> Route x.info (f x.run)) server
  
  -- | Mapps response of the server
  mapResponse :: (Functor m) => (Response -> Response) -> Server m -> Server m
  mapResponse f = mapServerFun $ \fun -> fmap (fmap f) . fun
  
  {-| API route finder strategy. The API can be transformed to some normal form
  for faster route lookup. So far we have two normal forms.
  One is plain Api type as it is. And another one is tree-structure
  where path switches are encoded with Map's.
  -}
  data FindRoute normalForm m = FindRoute
    { toNormalForm :: Api (Route m) -> normalForm (Route m)
    , getPath :: [Text] -> normalForm (Route m) -> Maybe (Route m, Api.CaptureMap)
    }
  
  -- | Use TreeApi normal form. Path switches are encoded as Maps.
  treeApiStrategy :: FindRoute TreeApi.TreeApi m
  treeApiStrategy =
    FindRoute
      { toNormalForm = TreeApi.toTreeApi
      , getPath = TreeApi.getPath
      }
  
  -- | Use plain api type. Just Api type as it is.
  plainApiStrategy :: FindRoute Api.Api m
  plainApiStrategy =
    FindRoute
      { toNormalForm = id
      , getPath = Api.getPath
      }
  
  {-| Converts server to server function. Server function can be used to implement low-level handlers
  in various server-libraries.
  -}
  fromServer :: forall m normalForm. (Monad m) => FindRoute normalForm m -> Server m -> ServerFun m
  fromServer strategy (Server server) = \req -> do
    case getRoute req of
      Just (routes, captureMap) -> routes.run req{capture = captureMap}
      Nothing -> pure Nothing
    where
      serverNormal = fmap strategy.toNormalForm $ toNormalApi (fillCaptures server)
  
      getRoute req = do
        api <- fromNormalApi req.method (getMediaType "Accept" req) (getMediaType "Content-Type" req) serverNormal
        strategy.getPath req.path api
  
      getMediaType name req = fromMaybe "*/*" $ Map.lookup name req.headers
  
  {-| Converts server to server function. Server function can be used to implement low-level handlers
  in various server-libraries. This function also uses LRU-cache to cache fetching of
  the routes
  -}
  fromServerWithCache :: forall m normalForm. (MonadIO m) => FindRoute normalForm m -> RouteCache m -> Server m -> ServerFun m
  fromServerWithCache strategy cache (Server server) = \req -> do
    mRoute <- liftIO $ withCache cache getRouteCache (getCacheKey req)
    case mRoute of
      Just (CacheValue captureMap routes) -> routes.run req{capture = captureMap}
      Nothing -> pure Nothing
    where
      serverNormal = fmap strategy.toNormalForm $ toNormalApi (fillCaptures server)
  
      getRouteCache :: CacheKey -> Maybe (CacheValue m)
      getRouteCache key = do
        api <- fromNormalApi key.method key.outputType key.inputType serverNormal
        uncurry (flip CacheValue) <$> strategy.getPath key.path api
  
  getCacheKey :: Request -> CacheKey
  getCacheKey req =
    CacheKey
      { inputType = getMediaType "Content-Type"
      , outputType = getMediaType "Accept"
      , method = req.method
      , path = req.path
      }
    where
      getMediaType name = fromMaybe "*/*" $ Map.lookup name req.headers
  
  {-| Substitutes all stars * for corresponding names in captures
  if there are more captures in the route than in the path it adds
  additional captures from the route to the path
  -}
  fillCaptures :: Api (Route m) -> Api (Route m)
  fillCaptures = go mempty 0
    where
      go pathSoFar n = \case
        Api.WithPath path api ->
          let (pathNext, m) = goPath (pathSoFar <> path) n path api
           in Api.WithPath pathNext (go (pathSoFar <> path) m api)
        Api.Append a b -> Api.Append (go pathSoFar n a) (go pathSoFar n b)
        Api.Empty -> Api.Empty
        Api.HandleRoute a -> goRoute pathSoFar n a
  
      goPath :: Api.Path -> Int -> Api.Path -> Api (Route m) -> (Api.Path, Int)
      goPath pathSoFar n (Api.Path path) api = case path of
        [] -> (Api.Path path, n)
        Api.CapturePath "*" : rest ->
          let (nextRest, m) = goPath pathSoFar (n + 1) (Api.Path rest) api
           in case getCaptureName n api of
                Just name -> (Api.Path [Api.CapturePath name] <> nextRest, m)
                Nothing -> error $ "No capture argument for start in path " <> Text.unpack (toUrlPiece pathSoFar) <> " at the index: " <> show n
        a : rest ->
          let (nextRest, m) = goPath pathSoFar n (Api.Path rest) api
           in (Api.Path [a] <> nextRest, m)
  
      goRoute pathSoFar pathCaptureCount route
        | missingCapturesCount > 0 = withMissingCaptures pathSoFar [pathCaptureCount .. routeCaptureCount - 1] (Api.HandleRoute route)
        | otherwise = Api.HandleRoute route
        where
          missingCapturesCount = routeCaptureCount - pathCaptureCount
  
          routeCaptureCount = captureCount route.info
  
      withMissingCaptures pathSoFar indexes route =
        Api.WithPath (Api.Path $ Api.CapturePath <$> names) route
        where
          names =
            fromMaybe (error $ "Not enough captures at path: " <> Text.unpack (toUrlPiece pathSoFar)) $
              mapM (\index -> getCaptureName index route) indexes
  
      captureCount routeInfo = List.foldl' count 0 routeInfo.inputs
        where
          count res inp = case inp.content of
            CaptureInput _ _ -> 1 + res
            _ -> res
  
  getCaptureName :: Int -> Api (Route m) -> Maybe Text
  getCaptureName index = \case
    Api.Append a _b -> rec a
    Api.Empty -> Nothing
    Api.WithPath _ a -> rec a
    Api.HandleRoute a -> mapMaybe (toCapture . Describe.content) a.info.inputs `atMay` index
    where
      rec = getCaptureName index
  
      toCapture :: RouteInput -> Maybe Text
      toCapture = \case
        CaptureInput name _ -> Just name
        _ -> Nothing
  
  -- | Adds tag to the route
  addTag :: Text -> Server m -> Server m
  addTag tag = mapRouteInfo (insertTag tag)
  
  -- | Sets description of the route
  setDescription :: Text -> Server m -> Server m
  setDescription desc = mapRouteInfo $ \info -> info{description = desc}
  
  -- | Sets summary of the route
  setSummary :: Text -> Server m -> Server m
  setSummary val = mapRouteInfo $ \info -> info{summary = val}
  
  -- | Maps over route API-information
  mapRouteInfo :: (RouteInfo -> RouteInfo) -> Server m -> Server m
  mapRouteInfo f (Server srv) = Server $ fmap (\route -> route{info = f route.info}) srv
  
  -- | Adds OpenApi tag to the route
  insertTag :: Text -> RouteInfo -> RouteInfo
  insertTag tag info = info{tags = tag : info.tags}
  
  {-| Appends descriptiton for the inputs. It passes pairs for @(input-name, input-description)@.
  special name request-body is dedicated to request body input
  nd raw-input is dedicated to raw input
  -}
  describeInputs :: [(Text, Text)] -> Server m -> Server m
  describeInputs descs = mapRouteInfo (describeInfoInputs descs)
  
  {-| Serves static files. The file path is a path to where to server the file.
  The media-type is derived from the extension. There is a special case if we need
  to server the file from the rooot of the server we can omit everything from the path
  but keep extension. Otherwise it is not able to derive the media type.
  
  It is convenient to use it with function @embedRecursiveDir@ from the library @file-embed@ or @file-embed-lzma@.
  -}
  staticFiles :: forall m. (MonadIO m) => [(FilePath, ByteString)] -> Server m
  staticFiles files =
    Server $ foldMap (uncurry serveFile) files
    where
      serveFile path content =
        unServer . mapRouteInfo (setOutputMedia media) . Server $
          ( if headMay path == Just '.'
              then id
              else ((fromString path) `Api.WithPath`)
          )
            (Api.HandleRoute (toRoute (getFile media content)))
        where
          media = getMediaType path
  
      getFile :: MediaType -> ByteString -> Get m (Resp AnyMedia BL.ByteString)
      getFile ty fileContent =
        Send $
          pure $
            addHeaders (setContent ty) $
              ok $
                BL.fromStrict fileContent
  
      getMediaType :: FilePath -> MediaType
      getMediaType path =
        fromMaybe "application/octet-stream" $
          Map.lookup (takeExtension path) extToMimeMap
  
  extToMimeMap :: Map String MediaType
  extToMimeMap =
    Map.fromList
      [ (".aac", "audio/aac") -- AAC audio
      , (".abw", "application/x-abiword") -- AbiWord document
      , (".arc", "application/x-freearc") -- Archive document (multiple files embedded)
      , (".avif", "image/avif") -- AVIF image
      , (".avi", "video/x-msvideo") -- 	AVI: Audio Video Interleave
      , (".azw", "application/vnd.amazon.ebook") -- 	Amazon Kindle eBook format
      , (".bin", "application/octet-stream") -- 	Any kind of binary data
      , (".bmp", "image/bmp") -- 	Windows OS/2 Bitmap Graphics
      , (".bz", "application/x-bzip") -- 	BZip archive
      , (".bz2", "application/x-bzip2") -- 	BZip2 archive
      , (".cda", "application/x-cdf") -- CD audio
      , (".csh", "application/x-csh") -- 	C-Shell script
      , (".css", "text/css") -- 	Cascading Style Sheets (CSS)
      , (".csv", "text/csv") -- 	Comma-separated values (CSV)
      , (".doc", "application/msword") -- 	Microsoft Word
      , (".docx", "application/vnd.openxmlformats-officedocument.wordprocessingml.document") -- 	Microsoft Word (OpenXML)
      , (".eot", "application/vnd.ms-fontobject") -- 	MS Embedded OpenType fonts
      , (".epub", "application/epub+zip") -- 	Electronic publication (EPUB)
      , (".gz", "application/gzip") -- 	GZip Compressed Archive
      , (".gif", "image/gif") -- 	Graphics Interchange Format (GIF)
      , (".htm", "text/html") -- , .html	HyperText Markup Language (HTML)
      , (".ico", "image/vnd.microsoft.icon") -- 	Icon format
      , (".ics", "text/calendar") -- 	iCalendar format
      , (".jar", "application/java-archive") -- 	Java Archive (JAR)
      , (".jpeg", "image/jpeg") -- JPEG images
      , (".jpg", "image/jpeg") -- JPEG images
      , (".js", "text/javascript") -- 	JavaScript	 (Specifications: HTML and RFC 9239)
      , (".json", "application/json") -- 	JSON format
      , (".jsonld", "application/ld+json") -- 	JSON-LD format
      , (".mid", "audio/midi") -- 	Musical Instrument Digital Interface (MIDI)	, audio/x-midi
      , (".midi", "audio/midi") -- 	Musical Instrument Digital Interface (MIDI)	, audio/x-midi
      , (".mjs", "text/javascript") -- 	JavaScript module
      , (".mp3", "audio/mpeg") -- 	MP3 audio
      , (".mp4", "video/mp4") -- MP4 video
      , (".mpeg", "video/mpeg") -- 	MPEG Video
      , (".mpkg", "application/vnd.apple.installer+xml") -- 	Apple Installer Package
      , (".odp", "application/vnd.oasis.opendocument.presentation") -- 	OpenDocument presentation document
      , (".ods", "application/vnd.oasis.opendocument.spreadsheet") -- 	OpenDocument spreadsheet document
      , (".odt", "application/vnd.oasis.opendocument.text") -- 	OpenDocument text document
      , (".oga", "audio/ogg") -- 	OGG audio
      , (".ogv", "video/ogg") -- 	OGG video
      , (".ogx", "application/ogg") -- 	OGG
      , (".opus", "audio/opus") -- Opus audio
      , (".otf", "font/otf") -- 	OpenType font
      , (".png", "image/png") -- 	Portable Network Graphics
      , (".pdf", "application/pdf") -- 	Adobe Portable Document Format (PDF)
      , (".php", "application/x-httpd-php") -- 	Hypertext Preprocessor (Personal Home Page)
      , (".ppt", "application/vnd.ms-powerpoint") -- 	Microsoft PowerPoint
      , (".pptx", "application/vnd.openxmlformats-officedocument.presentationml.presentation") -- 	Microsoft PowerPoint (OpenXML)
      , (".rar", "application/vnd.rar") -- 	RAR archive
      , (".rtf", "application/rtf") -- 	Rich Text Format (RTF)
      , (".sh", "application/x-sh") -- 	Bourne shell script
      , (".svg", "image/svg+xml") -- 	Scalable Vector Graphics (SVG)
      , (".tar", "application/x-tar") -- 	Tape Archive (TAR)
      , (".tif", "image/tiff") -- 	Tagged Image File Format (TIFF)
      , (".tiff", "image/tiff") -- 	Tagged Image File Format (TIFF)
      , (".ts", "video/mp2t") -- 	MPEG transport stream
      , (".ttf", "font/ttf") -- 	TrueType Font
      , (".txt", "text/plain") -- 	Text, (generally ASCII or ISO 8859-n)
      , (".vsd", "application/vnd.visio") -- 	Microsoft Visio
      , (".wav", "audio/wav") -- 	Waveform Audio Format
      , (".weba", "audio/webm") -- 	WEBM audio
      , (".webm", "video/webm") -- 	WEBM video
      , (".webp", "image/webp") -- 	WEBP image
      , (".woff", "font/woff") -- 	Web Open Font Format (WOFF)
      , (".woff2", "font/woff2") -- 	Web Open Font Format (WOFF)
      , (".xhtml", "application/xhtml+xml") -- 	XHTML
      , (".xls", "application/vnd.ms-excel") -- 	Microsoft Excel
      , (".xlsx", "application/vnd.openxmlformats-officedocument.spreadsheetml.sheet") -- 	Microsoft Excel (OpenXML)
      , (".xml", "application/xml") -- 	XML	 is recommended as of RFC 7303 (section 4.1), but text/xml is still used sometimes. You can assign a specific MIME type to a file with .xml extension depending on how its contents are meant to be interpreted. For instance, an Atom feed is application/atom+xml, but application/xml serves as a valid default.
      , (".xul", "application/vnd.mozilla.xul+xml") -- 	XUL
      , (".zip", "application/zip") -- 	ZIP archive
      , (".3gp", "video/3gpp") -- 	3GPP audio/video container	; audio/3gpp if it doesn't contain video
      , (".3g2", "video/3gpp2") -- 	3GPP2 audio/video container	; audio/3gpp2 if it doesn't contain video
      , (".7z", "application/x-7z-compressed") -- 	7-zip archive
      ]
  
  {- i wonder what is analog of this function?
  -- | Handle errors
  handleError ::(Exception a, MonadCatch m) => (a -> Server m) -> Server m -> Server m
  handleError handler (Server act) = Server $ \req ->
    (act req) `catch` (\err -> unServer (handler err) req)
  -}
  
  {-| Sub-server for a server on given path
  it might be usefule to emulate links from one route to another within the server
  or reuse part of the server inside another server.
  -}
  atPath :: forall m. Api.Path -> Server m -> Server m
  atPath rootPath rootServer = maybe mempty Server $ find rootPath rootServer.unServer
    where
      find :: Api.Path -> Api (Route m) -> Maybe (Api (Route m))
      find (Api.Path path) server = case path of
        [] -> Just server
        _ ->
          case server of
            Api.Empty -> Nothing
            Api.HandleRoute _ -> Nothing
            Api.Append a b -> find (Api.Path path) a <|> find (Api.Path path) b
            Api.WithPath (Api.Path pathB) serverB ->
              flip find serverB =<< matchPath pathB path
  
      matchPath :: [Api.PathItem] -> [Api.PathItem] -> Maybe Api.Path
      matchPath prefix path = case prefix of
        [] -> Just (Api.Path path)
        prefixHead : prefixTail -> do
          (pathHead, pathTail) <- List.uncons path
          guard (prefixHead == pathHead)
          matchPath prefixTail pathTail
  
  filterPath :: (Api.Path -> Bool) -> Server m -> Server m
  filterPath cond (Server a) =
    Server (Api.fromFlatApi $ filter (cond . fst) $ Api.flatApi a)
  
  -- | Returns a list of all paths in the server
  getServerPaths :: Server m -> [Api.Path]
  getServerPaths (Server a) = fmap fst $ Api.flatApi (fillCaptures a)
  
  {-| Links one route of the server to another
  so that every call to first path is redirected to the second path
  -}
  addPathLink :: Api.Path -> Api.Path -> Server m -> Server m
  addPathLink from to server =
    server <> Server (Api.WithPath from (atPath to server).unServer)
  