{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE StrictData #-}
module Distribution.Hackage.Types where
import Data.Aeson
import Data.ByteString.Lazy (toStrict)
import Data.Function
import Data.List.NonEmpty (toList)
import Data.Maybe
import Data.Proxy
import Data.Text (Text, unpack)
import Data.Time
import Distribution.PackageDescription
import Distribution.PackageDescription.Parsec
import Distribution.Parsec
import GHC.Generics (Generic)
import Network.HTTP.Media ((//), (/:))
import Servant.API
import Servant.API.ContentTypes
import Servant.Client
import Servant.Client.Core
data JSON0
instance Accept JSON0 where
contentType :: Proxy JSON0 -> MediaType
contentType Proxy JSON0
_ = MediaType
"application/json"
instance FromJSON a => MimeUnrender JSON0 a where
mimeUnrender :: Proxy JSON0 -> ByteString -> Either String a
mimeUnrender Proxy JSON0
_ = ByteString -> Either String a
forall a. FromJSON a => ByteString -> Either String a
eitherDecodeLenient
newtype Time = Time UTCTime
deriving newtype (Int -> Time -> ShowS
[Time] -> ShowS
Time -> String
(Int -> Time -> ShowS)
-> (Time -> String) -> ([Time] -> ShowS) -> Show Time
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Time] -> ShowS
$cshowList :: [Time] -> ShowS
show :: Time -> String
$cshow :: Time -> String
showsPrec :: Int -> Time -> ShowS
$cshowsPrec :: Int -> Time -> ShowS
Show, Time -> Time -> Bool
(Time -> Time -> Bool) -> (Time -> Time -> Bool) -> Eq Time
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Time -> Time -> Bool
$c/= :: Time -> Time -> Bool
== :: Time -> Time -> Bool
$c== :: Time -> Time -> Bool
Eq)
instance FromJSON Time where
parseJSON :: Value -> Parser Time
parseJSON = String -> (Text -> Parser Time) -> Value -> Parser Time
forall a. String -> (Text -> Parser a) -> Value -> Parser a
withText String
"time" ((Text -> Parser Time) -> Value -> Parser Time)
-> (Text -> Parser Time) -> Value -> Parser Time
forall a b. (a -> b) -> a -> b
$ \Text
t ->
case Bool -> TimeLocale -> String -> String -> Maybe UTCTime
forall (m :: Type -> Type) t.
(MonadFail m, ParseTime t) =>
Bool -> TimeLocale -> String -> String -> m t
parseTimeM Bool
False TimeLocale
defaultTimeLocale (Maybe String -> String
iso8601DateFormat (String -> Maybe String
forall a. a -> Maybe a
Just String
"%T%Z")) (Text -> String
unpack Text
t) of
Just UTCTime
time -> Time -> Parser Time
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (Time -> Parser Time) -> Time -> Parser Time
forall a b. (a -> b) -> a -> b
$ UTCTime -> Time
Time UTCTime
time
Maybe UTCTime
Nothing -> String -> Parser Time
forall (m :: Type -> Type) a. MonadFail m => String -> m a
fail String
"failed to parse time"
data Version
= Default
| Version Text
deriving (Int -> Version -> ShowS
[Version] -> ShowS
Version -> String
(Int -> Version -> ShowS)
-> (Version -> String) -> ([Version] -> ShowS) -> Show Version
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Version] -> ShowS
$cshowList :: [Version] -> ShowS
show :: Version -> String
$cshow :: Version -> String
showsPrec :: Int -> Version -> ShowS
$cshowsPrec :: Int -> Version -> ShowS
Show, Version -> Version -> Bool
(Version -> Version -> Bool)
-> (Version -> Version -> Bool) -> Eq Version
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Version -> Version -> Bool
$c/= :: Version -> Version -> Bool
== :: Version -> Version -> Bool
$c== :: Version -> Version -> Bool
Eq, (forall x. Version -> Rep Version x)
-> (forall x. Rep Version x -> Version) -> Generic Version
forall x. Rep Version x -> Version
forall x. Version -> Rep Version x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep Version x -> Version
$cfrom :: forall x. Version -> Rep Version x
Generic)
instance FromJSON Version where
parseJSON :: Value -> Parser Version
parseJSON = String -> (Text -> Parser Version) -> Value -> Parser Version
forall a. String -> (Text -> Parser a) -> Value -> Parser a
withText String
"version" ((Text -> Parser Version) -> Value -> Parser Version)
-> (Text -> Parser Version) -> Value -> Parser Version
forall a b. (a -> b) -> a -> b
$ Version -> Parser Version
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (Version -> Parser Version)
-> (Text -> Version) -> Text -> Parser Version
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Version
Version
data Package = Package
{ Package -> Text
packageName :: Text,
Package -> Version
version :: Version
}
deriving (Int -> Package -> ShowS
[Package] -> ShowS
Package -> String
(Int -> Package -> ShowS)
-> (Package -> String) -> ([Package] -> ShowS) -> Show Package
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Package] -> ShowS
$cshowList :: [Package] -> ShowS
show :: Package -> String
$cshow :: Package -> String
showsPrec :: Int -> Package -> ShowS
$cshowsPrec :: Int -> Package -> ShowS
Show, Package -> Package -> Bool
(Package -> Package -> Bool)
-> (Package -> Package -> Bool) -> Eq Package
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Package -> Package -> Bool
$c/= :: Package -> Package -> Bool
== :: Package -> Package -> Bool
$c== :: Package -> Package -> Bool
Eq, (forall x. Package -> Rep Package x)
-> (forall x. Rep Package x -> Package) -> Generic Package
forall x. Rep Package x -> Package
forall x. Package -> Rep Package x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep Package x -> Package
$cfrom :: forall x. Package -> Rep Package x
Generic)
instance FromJSON Package where
parseJSON :: Value -> Parser Package
parseJSON = String -> (Object -> Parser Package) -> Value -> Parser Package
forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject String
"package" ((Object -> Parser Package) -> Value -> Parser Package)
-> (Object -> Parser Package) -> Value -> Parser Package
forall a b. (a -> b) -> a -> b
$ \Object
o -> do
Text
packageName <- Object
o Object -> Text -> Parser Text
forall a. FromJSON a => Object -> Text -> Parser a
.: Text
"packageName"
let version :: Version
version = Version
Default
Package -> Parser Package
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (Package -> Parser Package) -> Package -> Parser Package
forall a b. (a -> b) -> a -> b
$ Package :: Text -> Version -> Package
Package {Text
Version
version :: Version
packageName :: Text
$sel:version:Package :: Version
$sel:packageName:Package :: Text
..}
instance ToHttpApiData Package where
toUrlPiece :: Package -> Text
toUrlPiece Package {Text
Version
version :: Version
packageName :: Text
$sel:version:Package :: Package -> Version
$sel:packageName:Package :: Package -> Text
..}
| Version
Default <- Version
version = Text
packageName
| Version Text
ver <- Version
version = Text
packageName Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"-" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
ver
data Revision = Revision
{ Revision -> Time
time :: Time,
Revision -> Text
user :: Text,
Revision -> Int
number :: Int
}
deriving (Int -> Revision -> ShowS
[Revision] -> ShowS
Revision -> String
(Int -> Revision -> ShowS)
-> (Revision -> String) -> ([Revision] -> ShowS) -> Show Revision
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Revision] -> ShowS
$cshowList :: [Revision] -> ShowS
show :: Revision -> String
$cshow :: Revision -> String
showsPrec :: Int -> Revision -> ShowS
$cshowsPrec :: Int -> Revision -> ShowS
Show, Revision -> Revision -> Bool
(Revision -> Revision -> Bool)
-> (Revision -> Revision -> Bool) -> Eq Revision
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Revision -> Revision -> Bool
$c/= :: Revision -> Revision -> Bool
== :: Revision -> Revision -> Bool
$c== :: Revision -> Revision -> Bool
Eq, (forall x. Revision -> Rep Revision x)
-> (forall x. Rep Revision x -> Revision) -> Generic Revision
forall x. Rep Revision x -> Revision
forall x. Revision -> Rep Revision x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep Revision x -> Revision
$cfrom :: forall x. Revision -> Rep Revision x
Generic)
deriving (Value -> Parser [Revision]
Value -> Parser Revision
(Value -> Parser Revision)
-> (Value -> Parser [Revision]) -> FromJSON Revision
forall a.
(Value -> Parser a) -> (Value -> Parser [a]) -> FromJSON a
parseJSONList :: Value -> Parser [Revision]
$cparseJSONList :: Value -> Parser [Revision]
parseJSON :: Value -> Parser Revision
$cparseJSON :: Value -> Parser Revision
FromJSON)
data Versions = Versions
{ Versions -> [Text]
normal :: [Text],
Versions -> [Text]
unpreferred :: [Text],
Versions -> [Text]
deprecated :: [Text]
}
deriving (Int -> Versions -> ShowS
[Versions] -> ShowS
Versions -> String
(Int -> Versions -> ShowS)
-> (Versions -> String) -> ([Versions] -> ShowS) -> Show Versions
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Versions] -> ShowS
$cshowList :: [Versions] -> ShowS
show :: Versions -> String
$cshow :: Versions -> String
showsPrec :: Int -> Versions -> ShowS
$cshowsPrec :: Int -> Versions -> ShowS
Show, Versions -> Versions -> Bool
(Versions -> Versions -> Bool)
-> (Versions -> Versions -> Bool) -> Eq Versions
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Versions -> Versions -> Bool
$c/= :: Versions -> Versions -> Bool
== :: Versions -> Versions -> Bool
$c== :: Versions -> Versions -> Bool
Eq, (forall x. Versions -> Rep Versions x)
-> (forall x. Rep Versions x -> Versions) -> Generic Versions
forall x. Rep Versions x -> Versions
forall x. Versions -> Rep Versions x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep Versions x -> Versions
$cfrom :: forall x. Versions -> Rep Versions x
Generic)
instance FromJSON Versions where
parseJSON :: Value -> Parser Versions
parseJSON = String -> (Object -> Parser Versions) -> Value -> Parser Versions
forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject String
"versions" ((Object -> Parser Versions) -> Value -> Parser Versions)
-> (Object -> Parser Versions) -> Value -> Parser Versions
forall a b. (a -> b) -> a -> b
$ \Object
o -> do
let withDefault :: Parser (Maybe [a]) -> Parser [a]
withDefault = (Maybe [a] -> [a]) -> Parser (Maybe [a]) -> Parser [a]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap ([a] -> Maybe [a] -> [a]
forall a. a -> Maybe a -> a
fromMaybe [])
[Text]
normal <- Parser (Maybe [Text]) -> Parser [Text]
forall a. Parser (Maybe [a]) -> Parser [a]
withDefault (Object
o Object -> Text -> Parser (Maybe [Text])
forall a. FromJSON a => Object -> Text -> Parser (Maybe a)
.:? Text
"normal-version")
[Text]
unpreferred <- Parser (Maybe [Text]) -> Parser [Text]
forall a. Parser (Maybe [a]) -> Parser [a]
withDefault (Object
o Object -> Text -> Parser (Maybe [Text])
forall a. FromJSON a => Object -> Text -> Parser (Maybe a)
.:? Text
"unprefereed-version")
[Text]
deprecated <- Parser (Maybe [Text]) -> Parser [Text]
forall a. Parser (Maybe [a]) -> Parser [a]
withDefault (Object
o Object -> Text -> Parser (Maybe [Text])
forall a. FromJSON a => Object -> Text -> Parser (Maybe a)
.:? Text
"deprecated-version")
Versions -> Parser Versions
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure Versions :: [Text] -> [Text] -> [Text] -> Versions
Versions {[Text]
deprecated :: [Text]
unpreferred :: [Text]
normal :: [Text]
$sel:deprecated:Versions :: [Text]
$sel:unpreferred:Versions :: [Text]
$sel:normal:Versions :: [Text]
..}
data Cabal
instance Accept Cabal where
contentType :: Proxy Cabal -> MediaType
contentType Proxy Cabal
_ = ByteString
"text" ByteString -> ByteString -> MediaType
// ByteString
"plain" MediaType -> (ByteString, ByteString) -> MediaType
/: (ByteString
"charset", ByteString
"utf-8")
instance MimeUnrender Cabal GenericPackageDescription where
mimeUnrender :: Proxy Cabal
-> ByteString -> Either String GenericPackageDescription
mimeUnrender Proxy Cabal
_ ByteString
f = Either String GenericPackageDescription
r
where
res' :: ParseResult GenericPackageDescription
res' = ByteString -> ParseResult GenericPackageDescription
parseGenericPackageDescription (ByteString -> ParseResult GenericPackageDescription)
-> ByteString -> ParseResult GenericPackageDescription
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
toStrict ByteString
f
([PWarning]
_, Either (Maybe Version, NonEmpty PError) GenericPackageDescription
res) = ParseResult GenericPackageDescription
-> ([PWarning],
Either (Maybe Version, NonEmpty PError) GenericPackageDescription)
forall a.
ParseResult a
-> ([PWarning], Either (Maybe Version, NonEmpty PError) a)
runParseResult ParseResult GenericPackageDescription
res'
showErrors :: [PError] -> String
showErrors [PError]
es =
String
"cabal file parse failed with the following errors:\n"
String -> ShowS
forall a. Semigroup a => a -> a -> a
<> [String] -> String
unlines ((PError -> String) -> [PError] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String -> PError -> String
showPError String
"") [PError]
es)
r :: Either String GenericPackageDescription
r = case Either (Maybe Version, NonEmpty PError) GenericPackageDescription
res of
Left (Maybe Version
_, NonEmpty PError
es') -> String -> Either String GenericPackageDescription
forall a b. a -> Either a b
Left (String -> Either String GenericPackageDescription)
-> String -> Either String GenericPackageDescription
forall a b. (a -> b) -> a -> b
$ [PError] -> String
showErrors ([PError] -> String) -> [PError] -> String
forall a b. (a -> b) -> a -> b
$ NonEmpty PError -> [PError]
forall a. NonEmpty a -> [a]
toList NonEmpty PError
es'
Right GenericPackageDescription
desc -> GenericPackageDescription
-> Either String GenericPackageDescription
forall a b. b -> Either a b
Right GenericPackageDescription
desc
data CabalFile
instance HasClient m api => HasClient m (CabalFile :> api) where
type Client m (CabalFile :> api) = Package -> Client m api
clientWithRoute :: Proxy m
-> Proxy (CabalFile :> api)
-> Request
-> Client m (CabalFile :> api)
clientWithRoute Proxy m
pm Proxy (CabalFile :> api)
Proxy Request
req = \p :: Package
p@Package {Text
Version
version :: Version
packageName :: Text
$sel:version:Package :: Package -> Version
$sel:packageName:Package :: Package -> Text
..} ->
Proxy m -> Proxy api -> Request -> Client m api
forall (m :: Type -> Type) api.
HasClient m api =>
Proxy m -> Proxy api -> Request -> Client m api
clientWithRoute Proxy m
pm (Proxy api
forall k (t :: k). Proxy t
Proxy @api) (Request -> Client m api) -> Request -> Client m api
forall a b. (a -> b) -> a -> b
$
Request
req
Request -> (Request -> Request) -> Request
forall a b. a -> (a -> b) -> b
& Text -> Request -> Request
appendToPath (Package -> Text
forall a. ToHttpApiData a => a -> Text
toQueryParam Package
p)
Request -> (Request -> Request) -> Request
forall a b. a -> (a -> b) -> b
& Text -> Request -> Request
appendToPath (Text
packageName Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
".cabal")
hoistClientMonad :: Proxy m
-> Proxy (CabalFile :> api)
-> (forall x. mon x -> mon' x)
-> Client mon (CabalFile :> api)
-> Client mon' (CabalFile :> api)
hoistClientMonad Proxy m
pm Proxy (CabalFile :> api)
Proxy forall x. mon x -> mon' x
f Client mon (CabalFile :> api)
cl = Proxy m
-> Proxy api
-> (forall x. mon x -> mon' x)
-> Client mon api
-> Client mon' api
forall (m :: Type -> Type) api (mon :: Type -> Type)
(mon' :: Type -> Type).
HasClient m api =>
Proxy m
-> Proxy api
-> (forall x. mon x -> mon' x)
-> Client mon api
-> Client mon' api
hoistClientMonad Proxy m
pm (Proxy api
forall k (t :: k). Proxy t
Proxy @api) forall x. mon x -> mon' x
f (Client mon api -> Client mon' api)
-> (Package -> Client mon api) -> Package -> Client mon' api
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Client mon (CabalFile :> api)
Package -> Client mon api
cl
type GetPackages = "packages" :> Get '[JSON0] [Package]
type GetVersions = "package" :> Capture "package" Package :> "preferred" :> Get '[JSON0] Versions
type GetRevisions = "package" :> Capture "package" Package :> "revisions" :> Get '[JSON0] [Revision]
type GetCabalFile = "package" :> CabalFile :> Get '[Cabal] GenericPackageDescription
type GetCabalFile' = "package" :> Capture "package" Package :> "revision" :> Capture "revision" Int :> Get '[Cabal] GenericPackageDescription
type HackageAPI =
GetPackages
:<|> GetVersions
:<|> GetRevisions
:<|> GetCabalFile
:<|> GetCabalFile'