{-# 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
, _NodeContent
, eltAttrsLens
, eltChildrenLens
, eltNameLens
#endif
, URIError(..)
, uriSchemeLens
, uriAuthorityLens
, uriPathLens
, uriQueryLens
, uriFragmentLens
, URI'(..)
, fromURI'
, toURI'
, readURI'
, showURI
, parseURIReference'
, parseURI'
, parseAbsoluteURI'
, parseRelativeReference'
, parseURIUnsafe
, appendURI
, appendURIs
, parentURI
, uriToString'
, HasParseError(fromParseError)
, HasURIError(fromURIError)
, 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 Test.QuickCheck (Arbitrary)
import Text.Parsec (ParseError)
$(makeLensesFor [("uriScheme", "uriSchemeLens"),
("uriAuthority", "uriAuthorityLens"),
("uriPath", "uriPathLens"),
("uriQuery", "uriQueryLens"),
("uriFragment", "uriFragmentLens")] ''URI)
showURI :: URI -> String
showURI (URI {..}) =
"URI {uriScheme = " <> show uriScheme <>
", uriAuthority = " <> show uriAuthority <>
", uriPath = " <> show uriPath <>
", uriQuery = " <> show uriQuery <>
", uriFragment = " <> show uriFragment <> "}"
parseURI' :: (HasURIError e, MonadError e m) => String -> m URI
parseURI' s = maybe (throwError $ fromURIError $ URIParseError "parseURI" s) return (parseURI s)
parseURIReference' :: (HasURIError e, MonadError e m) => String -> m URI
parseURIReference' s = maybe (throwError $ fromURIError $ URIParseError "parseURIReference" s) return (parseURIReference s)
parseAbsoluteURI' :: (HasURIError e, MonadError e m) => String -> m URI
parseAbsoluteURI' s = maybe (throwError $ fromURIError $ URIParseError "parseAbsoluteURI" s) return (parseAbsoluteURI s)
parseRelativeReference' :: (HasURIError e, MonadError e m) => String -> m URI
parseRelativeReference' s = maybe (throwError $ fromURIError $ URIParseError "parseRelativeReference" s) return (parseRelativeReference s)
parseURIUnsafe :: String -> URI
parseURIUnsafe s = fromMaybe (error ("parseURIUnsafe " ++ show s)) $ parseURIReference s
data URIError =
URIParseError String String
| URIAppendError URI URI
deriving (Eq, Ord, Show)
appendURI :: MonadError URIError m => URI -> URI -> m URI
appendURI (URI scheme auth path1 "" "") (URI "" Nothing path2 query fragment) = return $ URI scheme auth (path1 </> path2) query fragment
appendURI a b = throwError (URIAppendError a b)
appendURIs :: (Foldable t, MonadError URIError m) => t URI -> m URI
appendURIs uris = foldrM appendURI nullURI uris
parentURI :: URI -> URI
parentURI uri = uri {uriPath = takeDirectory (dropTrailingPathSeparator (uriPath uri))}
prop_append_singleton :: URI -> Bool
prop_append_singleton uri = appendURIs [uri] == Right uri
prop_print_parse :: URI -> Bool
prop_print_parse uri = parseURIReference (show uri) == Just uri
newtype URI' = URI' String deriving (Read, Show, Eq, Ord)
readURI' :: String -> Maybe URI'
readURI' s = maybe Nothing (const (Just (URI' s))) (parseURIReference s)
fromURI' :: URI' -> URI
fromURI' (URI' s) = fromJust (parseURI s)
toURI' :: URI -> URI'
toURI' = URI' . show
uriToString' :: URI -> String
uriToString' uri = uriToString id uri ""
instance Arbitrary URI where
class HasParseError e where fromParseError :: ParseError -> e
instance HasParseError ParseError where fromParseError = id
class HasURIError e where fromURIError :: URIError -> e
instance HasURIError URIError where fromURIError = id
instance Ord ParseError where
compare a b = compare (show a) (show b)