{-# LANGUAGE CPP, DeriveDataTypeable, OverloadedStrings, PackageImports, RecordWildCards, ScopedTypeVariables, StandaloneDeriving, TemplateHaskell, TypeFamilies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# OPTIONS -Wall -fno-warn-orphans #-}

module Debian.URI
    ( module Network.URI

#if 0
    , _NodeElement -- :: Prism' Node Element
    , _NodeContent -- :: Prism' Node Text
    , eltAttrsLens -- :: Lens' Element (HashMap AttrName AttrValue)
    , eltChildrenLens --  :: Lens' Element [Node]
    , eltNameLens -- :: Lens' Element Text
#endif

    , URIError(..)
    , uriSchemeLens
    , uriAuthorityLens
    , uriPathLens
    , uriQueryLens
    , uriFragmentLens
    -- * String known to parsable by parseURIReference.  Mainly
    -- useful because it has a Read instance.
    , URI'(..)
    , fromURI'
    , toURI'
    , readURI'

    -- Show URI as a Haskell expression
    , showURI
    -- Monadic URI parsers
    , parseURIReference'
    , parseURI'
    , parseAbsoluteURI'
    , parseRelativeReference'
    , parseURIUnsafe
    -- URI appending
    , appendURI
    , appendURIs
    , parentURI
    , uriToString'
    -- * Lift IO operations into a MonadError instance
    , HasParseError(fromParseError)
    , HasURIError(fromURIError)
    -- * QuickCheck properties
    , prop_print_parse
    , prop_append_singleton
    ) where

import Control.Lens (makeLensesFor)
import Control.Monad.Except (MonadError, throwError)
import Data.Foldable (foldrM)
import Data.Maybe (fromJust, fromMaybe)
#if !MIN_VERSION_base(4,11,0)
import Data.Monoid ((<>))
#endif
import Network.URI (nullURI, parseURIReference, parseURI, parseAbsoluteURI, parseRelativeReference, URI(..), URIAuth(..), uriToString)
import System.FilePath ((</>), dropTrailingPathSeparator, takeDirectory)
import Text.Parsec (ParseError)

$(makeLensesFor [("uriScheme", "uriSchemeLens"),
                 ("uriAuthority", "uriAuthorityLens"),
                 ("uriPath", "uriPathLens"),
                 ("uriQuery", "uriQueryLens"),
                 ("uriFragment", "uriFragmentLens")] ''URI)

showURI :: URI -> String
showURI :: URI -> [Char]
showURI (URI {[Char]
Maybe URIAuth
uriScheme :: URI -> [Char]
uriAuthority :: URI -> Maybe URIAuth
uriPath :: URI -> [Char]
uriQuery :: URI -> [Char]
uriFragment :: URI -> [Char]
uriFragment :: [Char]
uriQuery :: [Char]
uriPath :: [Char]
uriAuthority :: Maybe URIAuth
uriScheme :: [Char]
..}) =
    [Char]
"URI {uriScheme = " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> [Char]
show [Char]
uriScheme forall a. Semigroup a => a -> a -> a
<>
       [Char]
", uriAuthority = " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> [Char]
show Maybe URIAuth
uriAuthority forall a. Semigroup a => a -> a -> a
<>
       [Char]
", uriPath = " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> [Char]
show [Char]
uriPath forall a. Semigroup a => a -> a -> a
<>
       [Char]
", uriQuery = " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> [Char]
show [Char]
uriQuery forall a. Semigroup a => a -> a -> a
<>
       [Char]
", uriFragment = " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> [Char]
show [Char]
uriFragment forall a. Semigroup a => a -> a -> a
<> [Char]
"}"

-- | parseURI with MonadError
parseURI' :: (HasURIError e, MonadError e m) => String -> m URI
parseURI' :: forall e (m :: * -> *).
(HasURIError e, MonadError e m) =>
[Char] -> m URI
parseURI' [Char]
s = forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall a b. (a -> b) -> a -> b
$ forall e. HasURIError e => URIError -> e
fromURIError forall a b. (a -> b) -> a -> b
$ [Char] -> [Char] -> URIError
URIParseError [Char]
"parseURI" [Char]
s) forall (m :: * -> *) a. Monad m => a -> m a
return ([Char] -> Maybe URI
parseURI [Char]
s)
parseURIReference' :: (HasURIError e, MonadError e m) => String -> m URI
parseURIReference' :: forall e (m :: * -> *).
(HasURIError e, MonadError e m) =>
[Char] -> m URI
parseURIReference' [Char]
s = forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall a b. (a -> b) -> a -> b
$ forall e. HasURIError e => URIError -> e
fromURIError forall a b. (a -> b) -> a -> b
$ [Char] -> [Char] -> URIError
URIParseError [Char]
"parseURIReference" [Char]
s) forall (m :: * -> *) a. Monad m => a -> m a
return ([Char] -> Maybe URI
parseURIReference [Char]
s)
parseAbsoluteURI' :: (HasURIError e, MonadError e m) => String -> m URI
parseAbsoluteURI' :: forall e (m :: * -> *).
(HasURIError e, MonadError e m) =>
[Char] -> m URI
parseAbsoluteURI' [Char]
s = forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall a b. (a -> b) -> a -> b
$ forall e. HasURIError e => URIError -> e
fromURIError forall a b. (a -> b) -> a -> b
$ [Char] -> [Char] -> URIError
URIParseError [Char]
"parseAbsoluteURI" [Char]
s) forall (m :: * -> *) a. Monad m => a -> m a
return ([Char] -> Maybe URI
parseAbsoluteURI [Char]
s)
parseRelativeReference' :: (HasURIError e, MonadError e m) => String -> m URI
parseRelativeReference' :: forall e (m :: * -> *).
(HasURIError e, MonadError e m) =>
[Char] -> m URI
parseRelativeReference' [Char]
s = forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall a b. (a -> b) -> a -> b
$ forall e. HasURIError e => URIError -> e
fromURIError forall a b. (a -> b) -> a -> b
$ [Char] -> [Char] -> URIError
URIParseError [Char]
"parseRelativeReference" [Char]
s) forall (m :: * -> *) a. Monad m => a -> m a
return ([Char] -> Maybe URI
parseRelativeReference [Char]
s)

parseURIUnsafe :: String -> URI
parseURIUnsafe :: [Char] -> URI
parseURIUnsafe [Char]
s = forall a. a -> Maybe a -> a
fromMaybe (forall a. HasCallStack => [Char] -> a
error ([Char]
"parseURIUnsafe " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show [Char]
s)) forall a b. (a -> b) -> a -> b
$ [Char] -> Maybe URI
parseURIReference [Char]
s

--parseAbsoluteURI :: String -> Maybe URI
--parseRelativeReference :: String -> Maybe URI
--parseURI :: String -> Maybe URI
--parseURIReference :: String -> Maybe URI

data URIError =
    URIParseError String String
  | URIAppendError URI URI
  deriving (URIError -> URIError -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: URIError -> URIError -> Bool
$c/= :: URIError -> URIError -> Bool
== :: URIError -> URIError -> Bool
$c== :: URIError -> URIError -> Bool
Eq, Eq URIError
URIError -> URIError -> Bool
URIError -> URIError -> Ordering
URIError -> URIError -> URIError
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: URIError -> URIError -> URIError
$cmin :: URIError -> URIError -> URIError
max :: URIError -> URIError -> URIError
$cmax :: URIError -> URIError -> URIError
>= :: URIError -> URIError -> Bool
$c>= :: URIError -> URIError -> Bool
> :: URIError -> URIError -> Bool
$c> :: URIError -> URIError -> Bool
<= :: URIError -> URIError -> Bool
$c<= :: URIError -> URIError -> Bool
< :: URIError -> URIError -> Bool
$c< :: URIError -> URIError -> Bool
compare :: URIError -> URIError -> Ordering
$ccompare :: URIError -> URIError -> Ordering
Ord, Int -> URIError -> ShowS
[URIError] -> ShowS
URIError -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [URIError] -> ShowS
$cshowList :: [URIError] -> ShowS
show :: URIError -> [Char]
$cshow :: URIError -> [Char]
showsPrec :: Int -> URIError -> ShowS
$cshowsPrec :: Int -> URIError -> ShowS
Show)

-- | Conservative appending of absolute and relative URIs.  There may
-- be other cases that can be implemented, lets see if they turn up.
appendURI :: MonadError URIError m => URI -> URI -> m URI
    -- Append the two paths
appendURI :: forall (m :: * -> *). MonadError URIError m => URI -> URI -> m URI
appendURI (URI [Char]
scheme Maybe URIAuth
auth [Char]
path1 [Char]
"" [Char]
"") (URI [Char]
"" Maybe URIAuth
Nothing [Char]
path2 [Char]
query [Char]
fragment) = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ [Char] -> Maybe URIAuth -> [Char] -> [Char] -> [Char] -> URI
URI [Char]
scheme Maybe URIAuth
auth ([Char]
path1 [Char] -> ShowS
</> [Char]
path2) [Char]
query [Char]
fragment
    -- Use query from RHS
appendURI URI
a URI
b = forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (URI -> URI -> URIError
URIAppendError URI
a URI
b)

-- | Append a list of URI
-- @@
-- λ> appendURIs (parseURI "http://host.com") (parseURIRelative "/bar")
appendURIs :: (Foldable t, MonadError URIError m) => t URI -> m URI
appendURIs :: forall (t :: * -> *) (m :: * -> *).
(Foldable t, MonadError URIError m) =>
t URI -> m URI
appendURIs t URI
uris = forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> b -> m b) -> b -> t a -> m b
foldrM forall (m :: * -> *). MonadError URIError m => URI -> URI -> m URI
appendURI URI
nullURI t URI
uris

parentURI :: URI -> URI
parentURI :: URI -> URI
parentURI URI
uri = URI
uri {uriPath :: [Char]
uriPath = ShowS
takeDirectory (ShowS
dropTrailingPathSeparator (URI -> [Char]
uriPath URI
uri))}

-- properties
-- appendURIs [x] == x

prop_append_singleton :: URI -> Bool
prop_append_singleton :: URI -> Bool
prop_append_singleton URI
uri = forall (t :: * -> *) (m :: * -> *).
(Foldable t, MonadError URIError m) =>
t URI -> m URI
appendURIs [URI
uri] forall a. Eq a => a -> a -> Bool
== forall a b. b -> Either a b
Right URI
uri

prop_print_parse :: URI -> Bool
prop_print_parse :: URI -> Bool
prop_print_parse URI
uri = [Char] -> Maybe URI
parseURIReference (forall a. Show a => a -> [Char]
show URI
uri) forall a. Eq a => a -> a -> Bool
== forall a. a -> Maybe a
Just URI
uri

-- | A wrapper around a String containing a known parsable URI.  Not
-- absolutely safe, because you could say read "URI' \"bogus string\""
-- :: URI'.  But enough to save me from myself.
newtype URI' = URI' String deriving (ReadPrec [URI']
ReadPrec URI'
Int -> ReadS URI'
ReadS [URI']
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [URI']
$creadListPrec :: ReadPrec [URI']
readPrec :: ReadPrec URI'
$creadPrec :: ReadPrec URI'
readList :: ReadS [URI']
$creadList :: ReadS [URI']
readsPrec :: Int -> ReadS URI'
$creadsPrec :: Int -> ReadS URI'
Read, Int -> URI' -> ShowS
[URI'] -> ShowS
URI' -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [URI'] -> ShowS
$cshowList :: [URI'] -> ShowS
show :: URI' -> [Char]
$cshow :: URI' -> [Char]
showsPrec :: Int -> URI' -> ShowS
$cshowsPrec :: Int -> URI' -> ShowS
Show, URI' -> URI' -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: URI' -> URI' -> Bool
$c/= :: URI' -> URI' -> Bool
== :: URI' -> URI' -> Bool
$c== :: URI' -> URI' -> Bool
Eq, Eq URI'
URI' -> URI' -> Bool
URI' -> URI' -> Ordering
URI' -> URI' -> URI'
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: URI' -> URI' -> URI'
$cmin :: URI' -> URI' -> URI'
max :: URI' -> URI' -> URI'
$cmax :: URI' -> URI' -> URI'
>= :: URI' -> URI' -> Bool
$c>= :: URI' -> URI' -> Bool
> :: URI' -> URI' -> Bool
$c> :: URI' -> URI' -> Bool
<= :: URI' -> URI' -> Bool
$c<= :: URI' -> URI' -> Bool
< :: URI' -> URI' -> Bool
$c< :: URI' -> URI' -> Bool
compare :: URI' -> URI' -> Ordering
$ccompare :: URI' -> URI' -> Ordering
Ord)

readURI' :: String -> Maybe URI'
readURI' :: [Char] -> Maybe URI'
readURI' [Char]
s = forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. Maybe a
Nothing (forall a b. a -> b -> a
const (forall a. a -> Maybe a
Just ([Char] -> URI'
URI' [Char]
s))) ([Char] -> Maybe URI
parseURIReference [Char]
s)

fromURI' :: URI' -> URI
fromURI' :: URI' -> URI
fromURI' (URI' [Char]
s) = forall a. HasCallStack => Maybe a -> a
fromJust ([Char] -> Maybe URI
parseURI [Char]
s) -- this should provably parse

-- | Using the bogus Show instance of URI here.  If it ever gets fixed
-- this will stop working.  Worth noting that show will obscure any
-- password info embedded in the URI, so that's nice.
toURI' :: URI -> URI'
toURI' :: URI -> URI'
toURI' = [Char] -> URI'
URI' forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> [Char]
show

uriToString' :: URI -> String
uriToString' :: URI -> [Char]
uriToString' URI
uri = ShowS -> URI -> ShowS
uriToString forall a. a -> a
id URI
uri [Char]
""

class HasParseError e where fromParseError :: ParseError -> e
instance HasParseError ParseError where fromParseError :: ParseError -> ParseError
fromParseError = forall a. a -> a
id

class HasURIError e where fromURIError :: URIError -> e
instance HasURIError URIError where fromURIError :: URIError -> URIError
fromURIError = forall a. a -> a
id

instance Ord ParseError where
    compare :: ParseError -> ParseError -> Ordering
compare ParseError
a ParseError
b = forall a. Ord a => a -> a -> Ordering
compare (forall a. Show a => a -> [Char]
show ParseError
a) (forall a. Show a => a -> [Char]
show ParseError
b)