content: module Mig.Core.Class.Url (
    Url (..),
    UrlOf,
    renderUrl,
    ToUrl (..),
  ) where
  
  import Data.Aeson (ToJSON (..))
  import Data.Bifunctor
  import Data.Kind
  import Data.Map.Strict (Map)
  import Data.Map.Strict qualified as Map
  import Data.Maybe
  import Data.Proxy
  import Data.String
  import Data.Text (Text)
  import Data.Text qualified as Text
  import GHC.TypeLits
  import Mig.Core.Api (Path (..), PathItem (..), flatApi, fromFlatApi)
  import Mig.Core.Class.Route (Route (..))
  import Mig.Core.Server (Server (..), getServerPaths)
  import Mig.Core.Types.Info (RouteInfo, routeHasCapture, routeHasOptionalQuery, routeHasQuery, routeHasQueryFlag)
  import Mig.Core.Types.Pair
  import Mig.Core.Types.Route
  import Safe (headMay)
  import Web.HttpApiData
  
  -- | Url-template type.
  data Url = Url
    { path :: Path
    -- ^ relative path
    , queries :: [(Text, Text)]
    -- ^ queries in the URL
    , captures :: Map Text Text
    -- ^ map of captures
    }
  
  instance ToJSON Url where
    toJSON = toJSON . renderUrl @Text
  
  {-| Render URL to string-like value.
  
  TODO: use Text.Builder
  -}
  renderUrl :: (IsString a) => Url -> a
  renderUrl url =
    fromString $ Text.unpack $ appendQuery $ mappend "/" $ Text.intercalate "/" $ fmap fromPathItem url.path.unPath
    where
      fromPathItem :: PathItem -> Text
      fromPathItem = \case
        StaticPath text -> text
        CapturePath name -> fromMaybe ("{" <> name <> "}") $ Map.lookup name url.captures
  
      appendQuery = case url.queries of
        [] -> id
        _ -> \res -> mconcat [res, "?", query]
  
      query = Text.intercalate "&" $ fmap (\(name, val) -> mconcat [name, "=", val]) url.queries
  
  -------------------------------------------------------------------------------------
  -- render routes to safe URLs
  
  -- | Converts route type to URL function
  type family UrlOf a :: Type where
    UrlOf (Send method m a) = Url
    UrlOf (Query name value -> b) = (Query name value -> UrlOf b)
    UrlOf (Optional name value -> b) = (Optional name value -> UrlOf b)
    UrlOf (Capture name value -> b) = (Capture name value -> UrlOf b)
    UrlOf (QueryFlag name -> b) = (QueryFlag name -> UrlOf b)
    UrlOf (Header name value -> b) = UrlOf b
    UrlOf (OptionalHeader name value -> b) = UrlOf b
    UrlOf (Body media value -> b) = UrlOf b
    UrlOf (Cookie value -> b) = UrlOf b
    UrlOf (PathInfo -> b) = UrlOf b
    UrlOf (FullPathInfo -> b) = UrlOf b
    UrlOf (RawRequest -> b) = UrlOf b
    UrlOf (IsSecure -> b) = UrlOf b
    UrlOf (a, b) = (UrlOf a, UrlOf b)
    UrlOf (a, b, c) = (UrlOf a, UrlOf b, UrlOf c)
    UrlOf (a, b, c, d) = (UrlOf a, UrlOf b, UrlOf c, UrlOf d)
    UrlOf (a, b, c, d, e) = (UrlOf a, UrlOf b, UrlOf c, UrlOf d, UrlOf e)
    UrlOf (a, b, c, d, e, f) = (UrlOf a, UrlOf b, UrlOf c, UrlOf d, UrlOf e, UrlOf f)
    UrlOf (a :| b) = UrlOf a :| UrlOf b
  
  {-| Converts server to safe url. We can use it to generate
  safe URL constructors to be used in HTML templates
  An example of how we can create safe URL's. Note
  that order of URL's should be the same as in server definition:
  
  > type GreetingRoute = Get Html
  > type BlogPostRoute = Optional "id" BlogPostId -> Get Html
  > type ListPostsRoute = Get Html
  >
  > data Routes = Routes
  >   { greeting :: GreetingRoute
  >   , blogPost :: BlogPostRoute
  >   , listPosts :: ListPostsRoute
  >   }
  >
  > -- URLs
  >
  > data Urls = Urls
  >   { greeting :: UrlOf GreetingRoute
  >   , blogPost :: UrlOf BlogPostRoute
  >   , listPosts :: UrlOf ListPostsRoute
  >   }
  >
  > {\-| Site URL's
  > URL's should be listed in the same order as they appear in the server
  > -\}
  > urls :: Urls
  > urls = Urls{..}
  >   where
  >     greeting
  >       :| blogPost
  >       :| listPosts
  >         toUrl (server undefined)
  -}
  class ToUrl a where
    toUrl :: Server m -> a
    mapUrl :: (Url -> Url) -> a -> a
    urlArity :: Int
  
  instance (ToUrl a, ToUrl b) => ToUrl (a :| b) where
    toUrl api = a :| b
      where
        (a, b) = toUrl api
    mapUrl f (a :| b) = (mapUrl f a :| mapUrl f b)
    urlArity = urlArity @(a, b)
  
  instance (ToUrl a, ToUrl b) => ToUrl (a, b) where
    toUrl (Server api) = (toUrl (Server apiA), toUrl (Server apiB))
      where
        (apiA, apiB) = bimap fromFlatApi fromFlatApi $ Prelude.splitAt (urlArity @a) (flatApi api)
  
    mapUrl f (a, b) = (mapUrl f a, mapUrl f b)
    urlArity = urlArity @a + urlArity @b
  
  instance (ToUrl a, ToUrl b, ToUrl c) => ToUrl (a, b, c) where
    toUrl server = fromPair $ toUrl @(a, (b, c)) server
      where
        fromPair (a, (b, c)) = (a, b, c)
  
    mapUrl f (a, b, c) = (mapUrl f a, mapUrl f b, mapUrl f c)
    urlArity = urlArity @a + urlArity @b + urlArity @c
  
  instance (ToUrl a, ToUrl b, ToUrl c, ToUrl d) => ToUrl (a, b, c, d) where
    toUrl server = fromPair $ toUrl @(a, (b, c, d)) server
      where
        fromPair (a, (b, c, d)) = (a, b, c, d)
  
    mapUrl f (a, b, c, d) = (mapUrl f a, mapUrl f b, mapUrl f c, mapUrl f d)
    urlArity = urlArity @a + urlArity @b + urlArity @c + urlArity @d
  
  instance ToUrl Url where
    toUrl server = case getServerPaths server of
      url : _ -> Url url [] mempty
      _ -> Url mempty mempty mempty
  
    mapUrl f a = f a
    urlArity = 1
  
  -- query
  
  instance (KnownSymbol sym, ToHttpApiData a, ToUrl b) => ToUrl (Query sym a -> b) where
    toUrl server = \(Query val) ->
      whenOrError (hasQuery (getName @sym) server) noQuery $
        mapUrl (insertQuery (getName @sym) (toUrlPiece val)) (toUrl @b server)
      where
        noQuery = noInputMessage ("query with name: " <> getName @sym) server
  
    mapUrl f a = \query -> mapUrl f (a query)
    urlArity = urlArity @b
  
  insertQuery :: Text -> Text -> Url -> Url
  insertQuery name val url = url{queries = (name, val) : url.queries}
  
  hasQuery :: Text -> Server m -> Bool
  hasQuery name = hasInput (routeHasQuery name)
  
  -- optional query
  
  instance (KnownSymbol sym, ToHttpApiData a, ToUrl b) => ToUrl (Optional sym a -> b) where
    toUrl server = \(Optional mVal) ->
      whenOrError (hasOptionalQuery (getName @sym) server) noOptionalQuery $
        mapUrl (maybe id (insertQuery (getName @sym) . toUrlPiece) mVal) (toUrl @b server)
      where
        noOptionalQuery = noInputMessage ("optional query with name: " <> getName @sym) server
  
    mapUrl f a = \query -> mapUrl f (a query)
    urlArity = urlArity @b
  
  hasOptionalQuery :: Text -> Server m -> Bool
  hasOptionalQuery name = hasInput (routeHasOptionalQuery name)
  
  -- query flag
  
  instance (KnownSymbol sym, ToUrl b) => ToUrl (QueryFlag sym -> b) where
    toUrl server = \(QueryFlag val) ->
      whenOrError (hasQueryFlag (getName @sym) server) noQueryFlag $
        mapUrl (insertQuery (getName @sym) (toUrlPiece val)) (toUrl @b server)
      where
        noQueryFlag = noInputMessage ("query flag with name: " <> getName @sym) server
  
    mapUrl f a = \query -> mapUrl f (a query)
    urlArity = urlArity @b
  
  hasQueryFlag :: Text -> Server m -> Bool
  hasQueryFlag name = hasInput (routeHasQueryFlag name)
  
  -- capture
  
  instance (KnownSymbol sym, ToHttpApiData a, ToUrl b) => ToUrl (Capture sym a -> b) where
    toUrl server = \(Capture val) ->
      whenOrError (hasCapture (getName @sym) server) noCapture $
        mapUrl (insertCapture (getName @sym) (toUrlPiece val)) (toUrl @b server)
      where
        noCapture = noInputMessage ("Capture with name: " <> getName @sym) server
  
    mapUrl f a = \capture -> mapUrl f (a capture)
    urlArity = urlArity @b
  
  insertCapture :: Text -> Text -> Url -> Url
  insertCapture name val url = url{captures = Map.insert name val url.captures}
  
  hasCapture :: Text -> Server m -> Bool
  hasCapture name = hasInput (routeHasCapture name)
  
  -------------------------------------------------------------------------------------
  -- utils
  
  getName :: forall sym a. (KnownSymbol sym, IsString a) => a
  getName = fromString (symbolVal (Proxy @sym))
  
  hasInput :: (RouteInfo -> Bool) -> Server m -> Bool
  hasInput check (Server api) =
    maybe False (check . (.info) . snd) $ headMay $ flatApi api
  
  noInputMessage :: String -> Server m -> String
  noInputMessage item (Server api) =
    unlines
      [ unwords ["Server has no", item, "at route", route]
      , "Check the order of routes on the left side of toUrl expression"
      ]
    where
      route = maybe "unknown" (Text.unpack . toUrlPiece . fst) $ headMay (flatApi api)
  
  whenOrError :: Bool -> String -> a -> a
  whenOrError cond message a
    | cond = a
    | otherwise = error message
  