
  0 | module TyTTP.URL.Simple
  1 | 
  2 | import public Control.Monad.Either
  3 | import Data.List
  4 | import Data.String
  5 | import TyTTP
  6 | import TyTTP.URL.Definition
  7 | 
  8 | public export
  9 | SimpleURL : Type
 10 | SimpleURL = URL String String String
 11 | 
 12 | public export
 13 | data URLParserError
 14 |   = EmptyString
 15 |   | MissingAuthorityOrPath
 16 | 
 17 | export -- visible for testing
 18 | parse : String -> Either URLParserError SimpleURL
 19 | parse str = scheme (unpack $ trim str) $ MkURL Nothing Nothing "" ""
 20 |   where
 21 |     search : List Char -> SimpleURL -> Either URLParserError SimpleURL
 22 |     search [] url = Right url
 23 |     search xs url = Right $ { search := pack xs } url
 24 | 
 25 |     path : List Char -> SimpleURL -> Either URLParserError SimpleURL
 26 |     path [] url = Right $ { path := "/" } url
 27 |     path xs url =
 28 |       let (p, rest) = List.break (== '?') xs
 29 |       in search rest $ { path := pack p } url
 30 | 
 31 |     authority : List Char -> SimpleURL -> Either URLParserError SimpleURL
 32 |     authority ('/' :: '/' :: xs) url =
 33 |       let (auth, rest) = List.break (== '/') xs
 34 |       in path rest $ { authority := Just $ pack auth } url
 35 |     authority [] _ = Left MissingAuthorityOrPath
 36 |     authority x url = path x url
 37 | 
 38 |     scheme : List Char -> SimpleURL -> Either URLParserError SimpleURL
 39 |     scheme ('h' :: 't' :: 't' :: 'p' :: xs) url = 
 40 |       case xs of
 41 |          ('s' :: ':' :: ys) => authority ys $ { scheme := Just HTTPS } url
 42 |          (':' :: ys) => authority ys $ { scheme := Just HTTP } url
 43 |          xs => path ('h' :: 't' :: 't' :: 'p' :: xs) url
 44 |     scheme [] _ = Left EmptyString
 45 |     scheme xs url = authority xs url
 46 | 
 47 | export
 48 | parseUrl : MonadError URLParserError m
 49 |   => (
 50 |     Context me SimpleURL v h1 s h2 a b
 51 |     -> m $ Context me' SimpleURL v' h1' s' h2' a' b'
 52 |   )
 53 |   -> Context me String v h1 s h2 a b
 54 |   -> m $ Context me' String v' h1' s' h2' a' b'
 55 | parseUrl handler ctx = case parse ctx.request.url of
 56 |   Right u => do
 57 |     result <- handler $ { request.url := u } ctx
 58 |     pure $ { request.url := ctx.request.url } result
 59 |   Left err => throwError err
 60 | 
 61 | export
 62 | parseUrl' : Monad m
 63 |   => (
 64 |     URLParserError
 65 |     -> Context me String v h1 s h2 a b
 66 |     -> m $ Context me' String v' h1' s' h2' a' b'
 67 |   )
 68 |   -> (
 69 |     Context me SimpleURL v h1 s h2 a b
 70 |     -> EitherT URLParserError m $ Context me' SimpleURL v' h1' s' h2' a' b'
 71 |   )
 72 |   -> Context me String v h1 s h2 a b
 73 |   -> m $ Context me' String v' h1' s' h2' a' b'
 74 | parseUrl' errHandler handler ctx = do
 75 |   Right result <- runEitherT $ Simple.parseUrl handler ctx
 76 |     | Left err => errHandler err ctx
 77 |   pure result
 78 | 
 79 | 
 80 |