{-# 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

-----------------------------------------------------------
-- Servant API Types

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'