module Web.View.Types.Url where

import Control.Applicative ((<|>))
import Data.Bifunctor (first)
import Data.Maybe (fromMaybe)
import Data.String (IsString (..))
import Data.Text (Text, pack)
import Data.Text qualified as T
import Data.Text.Encoding (decodeUtf8, encodeUtf8)
import Effectful
import Effectful.State.Static.Local
import Network.HTTP.Types (Query, parseQuery, renderQuery)


type Segment = Text


pathUrl :: [Segment] -> Url
pathUrl :: [Segment] -> Url
pathUrl [Segment]
p = Segment -> Segment -> [Segment] -> Query -> Url
Url Segment
"" Segment
"" [Segment]
p []


cleanSegment :: Segment -> Segment
cleanSegment :: Segment -> Segment
cleanSegment = (Char -> Bool) -> Segment -> Segment
T.dropWhileEnd (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'/') (Segment -> Segment) -> (Segment -> Segment) -> Segment -> Segment
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> Segment -> Segment
T.dropWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'/')


pathSegments :: Text -> [Segment]
pathSegments :: Segment -> [Segment]
pathSegments Segment
p = (Segment -> Bool) -> [Segment] -> [Segment]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (Segment -> Bool) -> Segment -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Segment -> Bool
T.null) ([Segment] -> [Segment]) -> [Segment] -> [Segment]
forall a b. (a -> b) -> a -> b
$ HasCallStack => Segment -> Segment -> [Segment]
Segment -> Segment -> [Segment]
T.splitOn Segment
"/" (Segment -> [Segment]) -> Segment -> [Segment]
forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> Segment -> Segment
T.dropWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'/') Segment
p


-- Problem: if scheme and domain exist, it MUST be an absolute url
data Url = Url
  { Url -> Segment
scheme :: Text
  , Url -> Segment
domain :: Text
  , Url -> [Segment]
path :: [Segment]
  , Url -> Query
query :: Query
  }
  deriving (Url -> Url -> Bool
(Url -> Url -> Bool) -> (Url -> Url -> Bool) -> Eq Url
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Url -> Url -> Bool
== :: Url -> Url -> Bool
$c/= :: Url -> Url -> Bool
/= :: Url -> Url -> Bool
Eq)
instance IsString Url where
  fromString :: String -> Url
fromString = Segment -> Url
url (Segment -> Url) -> (String -> Segment) -> String -> Url
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Segment
pack
instance Show Url where
  show :: Url -> String
show = Segment -> String
forall a. Show a => a -> String
show (Segment -> String) -> (Url -> Segment) -> Url -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Url -> Segment
renderUrl
instance Read Url where
  readsPrec :: Int -> ReadS Url
readsPrec Int
_ String
s =
    (Segment -> Url) -> (Segment, String) -> (Url, String)
forall a b c. (a -> b) -> (a, c) -> (b, c)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first Segment -> Url
url ((Segment, String) -> (Url, String))
-> [(Segment, String)] -> [(Url, String)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Read a => ReadS a
reads @Text String
s
instance Semigroup Url where
  Url Segment
s Segment
d [Segment]
p Query
q <> :: Url -> Url -> Url
<> Url Segment
_ Segment
_ [Segment]
p2 Query
q2 = Segment -> Segment -> [Segment] -> Query -> Url
Url Segment
s Segment
d ([Segment]
p [Segment] -> [Segment] -> [Segment]
forall a. Semigroup a => a -> a -> a
<> [Segment]
p2) (Query
q Query -> Query -> Query
forall a. Semigroup a => a -> a -> a
<> Query
q2)
instance Monoid Url where
  mempty :: Url
mempty = Segment -> Segment -> [Segment] -> Query -> Url
Url Segment
"" Segment
"" [] []


url :: Text -> Url
url :: Segment -> Url
url Segment
t = Eff '[] Url -> Url
forall a. HasCallStack => Eff '[] a -> a
runPureEff (Eff '[] Url -> Url) -> Eff '[] Url -> Url
forall a b. (a -> b) -> a -> b
$ Segment -> Eff '[State Segment] Url -> Eff '[] Url
forall s (es :: [(* -> *) -> * -> *]) a.
HasCallStack =>
s -> Eff (State s : es) a -> Eff es a
evalState Segment
t (Eff '[State Segment] Url -> Eff '[] Url)
-> Eff '[State Segment] Url -> Eff '[] Url
forall a b. (a -> b) -> a -> b
$ do
  Segment
s <- Eff '[State Segment] Segment
scheme
  Segment
d <- Segment -> Eff '[State Segment] Segment
forall {a} {es :: [(* -> *) -> * -> *]}.
(Eq a, IsString a, State Segment :> es) =>
a -> Eff es Segment
domain Segment
s
  [Segment]
ps <- Eff '[State Segment] [Segment]
forall (es :: [(* -> *) -> * -> *]).
(State Segment :> es) =>
Eff es [Segment]
paths
  Query
q <- Eff '[State Segment] Query
forall (es :: [(* -> *) -> * -> *]).
(State Segment :> es) =>
Eff es Query
query
  Url -> Eff '[State Segment] Url
forall a. a -> Eff '[State Segment] a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Url -> Eff '[State Segment] Url)
-> Url -> Eff '[State Segment] Url
forall a b. (a -> b) -> a -> b
$ Url{$sel:scheme:Url :: Segment
scheme = Segment
s, $sel:domain:Url :: Segment
domain = Segment
d, $sel:path:Url :: [Segment]
path = [Segment]
ps, $sel:query:Url :: Query
query = Query
q}
 where
  parse :: (State Text :> es) => (Char -> Bool) -> Eff es Text
  parse :: forall (es :: [(* -> *) -> * -> *]).
(State Segment :> es) =>
(Char -> Bool) -> Eff es Segment
parse Char -> Bool
b = do
    Segment
inp <- Eff es Segment
forall s (es :: [(* -> *) -> * -> *]).
(HasCallStack, State s :> es) =>
Eff es s
get
    let match :: Segment
match = (Char -> Bool) -> Segment -> Segment
T.takeWhile Char -> Bool
b Segment
inp
        rest :: Segment
rest = (Char -> Bool) -> Segment -> Segment
T.dropWhile Char -> Bool
b Segment
inp
    Segment -> Eff es ()
forall s (es :: [(* -> *) -> * -> *]).
(HasCallStack, State s :> es) =>
s -> Eff es ()
put Segment
rest
    Segment -> Eff es Segment
forall a. a -> Eff es a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Segment
match

  string :: (State Text :> es) => Text -> Eff es (Maybe Text)
  string :: forall (es :: [(* -> *) -> * -> *]).
(State Segment :> es) =>
Segment -> Eff es (Maybe Segment)
string Segment
pre = do
    Segment
inp <- Eff es Segment
forall s (es :: [(* -> *) -> * -> *]).
(HasCallStack, State s :> es) =>
Eff es s
get
    case Segment -> Segment -> Maybe Segment
T.stripPrefix Segment
pre Segment
inp of
      Maybe Segment
Nothing -> Maybe Segment -> Eff es (Maybe Segment)
forall a. a -> Eff es a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Segment
forall a. Maybe a
Nothing
      Just Segment
rest -> do
        Segment -> Eff es ()
forall s (es :: [(* -> *) -> * -> *]).
(HasCallStack, State s :> es) =>
s -> Eff es ()
put Segment
rest
        Maybe Segment -> Eff es (Maybe Segment)
forall a. a -> Eff es a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Segment -> Maybe Segment
forall a. a -> Maybe a
Just Segment
pre)

  -- it's either scheme AND domain, or relative path
  scheme :: Eff '[State Segment] Segment
scheme = do
    Maybe Segment
http <- Segment -> Eff '[State Segment] (Maybe Segment)
forall (es :: [(* -> *) -> * -> *]).
(State Segment :> es) =>
Segment -> Eff es (Maybe Segment)
string Segment
"http://"
    Maybe Segment
https <- Segment -> Eff '[State Segment] (Maybe Segment)
forall (es :: [(* -> *) -> * -> *]).
(State Segment :> es) =>
Segment -> Eff es (Maybe Segment)
string Segment
"https://"
    Segment -> Eff '[State Segment] Segment
forall a. a -> Eff '[State Segment] a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Segment -> Eff '[State Segment] Segment)
-> Segment -> Eff '[State Segment] Segment
forall a b. (a -> b) -> a -> b
$ Segment -> Maybe Segment -> Segment
forall a. a -> Maybe a -> a
fromMaybe Segment
"" (Maybe Segment -> Segment) -> Maybe Segment -> Segment
forall a b. (a -> b) -> a -> b
$ Maybe Segment
http Maybe Segment -> Maybe Segment -> Maybe Segment
forall a. Maybe a -> Maybe a -> Maybe a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Maybe Segment
https

  domain :: a -> Eff es Segment
domain a
"" = Segment -> Eff es Segment
forall a. a -> Eff es a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Segment
""
  domain a
_ = (Char -> Bool) -> Eff es Segment
forall (es :: [(* -> *) -> * -> *]).
(State Segment :> es) =>
(Char -> Bool) -> Eff es Segment
parse (Bool -> Bool
not (Bool -> Bool) -> (Char -> Bool) -> Char -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Bool
isDomainSep)

  pathText :: (State Text :> es) => Eff es Text
  pathText :: forall (es :: [(* -> *) -> * -> *]).
(State Segment :> es) =>
Eff es Segment
pathText = (Char -> Bool) -> Eff es Segment
forall (es :: [(* -> *) -> * -> *]).
(State Segment :> es) =>
(Char -> Bool) -> Eff es Segment
parse (Bool -> Bool
not (Bool -> Bool) -> (Char -> Bool) -> Char -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Bool
isQuerySep)

  paths :: (State Text :> es) => Eff es [Segment]
  paths :: forall (es :: [(* -> *) -> * -> *]).
(State Segment :> es) =>
Eff es [Segment]
paths = do
    Segment
p <- Eff es Segment
forall (es :: [(* -> *) -> * -> *]).
(State Segment :> es) =>
Eff es Segment
pathText
    [Segment] -> Eff es [Segment]
forall a. a -> Eff es a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Segment] -> Eff es [Segment]) -> [Segment] -> Eff es [Segment]
forall a b. (a -> b) -> a -> b
$ Segment -> [Segment]
pathSegments Segment
p

  query :: (State Text :> es) => Eff es Query
  query :: forall (es :: [(* -> *) -> * -> *]).
(State Segment :> es) =>
Eff es Query
query = do
    Segment
q <- (Char -> Bool) -> Eff es Segment
forall (es :: [(* -> *) -> * -> *]).
(State Segment :> es) =>
(Char -> Bool) -> Eff es Segment
parse (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'\n')
    Query -> Eff es Query
forall a. a -> Eff es a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Query -> Eff es Query) -> Query -> Eff es Query
forall a b. (a -> b) -> a -> b
$ ByteString -> Query
parseQuery (ByteString -> Query) -> ByteString -> Query
forall a b. (a -> b) -> a -> b
$ Segment -> ByteString
encodeUtf8 Segment
q

  isDomainSep :: Char -> Bool
isDomainSep Char
'/' = Bool
True
  isDomainSep Char
_ = Bool
False

  isQuerySep :: Char -> Bool
isQuerySep Char
'?' = Bool
True
  isQuerySep Char
_ = Bool
False


renderUrl :: Url -> Text
renderUrl :: Url -> Segment
renderUrl Url
u = Url
u.scheme Segment -> Segment -> Segment
forall a. Semigroup a => a -> a -> a
<> Url
u.domain Segment -> Segment -> Segment
forall a. Semigroup a => a -> a -> a
<> [Segment] -> Segment
paths Url
u.path Segment -> Segment -> Segment
forall a. Semigroup a => a -> a -> a
<> ByteString -> Segment
decodeUtf8 (Bool -> Query -> ByteString
renderQuery Bool
True Url
u.query)
 where
  paths :: [Segment] -> Text
  paths :: [Segment] -> Segment
paths [Segment]
ss = Segment
"/" Segment -> Segment -> Segment
forall a. Semigroup a => a -> a -> a
<> Segment -> [Segment] -> Segment
T.intercalate Segment
"/" ((Segment -> Segment) -> [Segment] -> [Segment]
forall a b. (a -> b) -> [a] -> [b]
map Segment -> Segment
cleanSegment [Segment]
ss)