diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,5 @@ +# arch-web + +## 0.1.0 + +Initial release diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,21 @@ +MIT License + +Copyright (c) 2021 berberman + +Permission is hereby granted, free of charge, to any person obtaining a copy +of this software and associated documentation files (the "Software"), to deal +in the Software without restriction, including without limitation the rights +to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +copies of the Software, and to permit persons to whom the Software is +furnished to do so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included in all +copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +SOFTWARE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,49 @@ +# arch-web + +[![Hackage](https://img.shields.io/hackage/v/arch-web.svg?logo=haskell)](https://hackage.haskell.org/package/arch-web) +[![MIT license](https://img.shields.io/badge/license-MIT-blue.svg)](LICENSE) +![build](https://github.com/berberman/arch-web/workflows/build/badge.svg) + + +`arch-web` is a simple library providing functions to access [Official repositories web interface](https://wiki.archlinux.org/index.php/Official_repositories_web_interface) and [Aurweb RPC interface](https://wiki.archlinux.org/index.php/Aurweb_RPC_interface), based on [servant-client](https://hackage.haskell.org/package/servant-client). + +## Documentation + +Documentation of released version is available at [hackage](https://hackage.haskell.org/package/arch-web), +and of master is at [github pages](https://berberman.github.io/arch-web). + +## Example + +* Print [linux](https://archlinux.org/packages/core/x86_64/linux/)'s version: + +```haskell +import Control.Lens +import Control.Monad (void) +import Control.Monad.IO.Class (liftIO) +import qualified Data.Text as T +import Web.ArchLinux +import Web.ArchLinux.Types.Lens + +main :: IO () +main = void . runAPIClient' $ do + linux <- getPackageDetails Core X86_64 "linux" + liftIO . putStrLn $ "linux in [core] has version: " <> T.unpack (linux ^. pkgver) +``` + +* Search keywords "yay": + +```haskell +import Control.Lens +import Control.Monad (void) +import Control.Monad.IO.Class (liftIO) +import Web.ArchLinux +import Web.ArchLinux.Types.Lens + +main :: IO () +main = void . runAPIClient' $ do + response <- searchAur ByNameOrDesc "yay" + liftIO . print $ (response ^. results ^.. each . name) +``` + +* ... + diff --git a/arch-web.cabal b/arch-web.cabal new file mode 100644 --- /dev/null +++ b/arch-web.cabal @@ -0,0 +1,101 @@ +cabal-version: 2.2 +name: arch-web +version: 0.1.0 +synopsis: Arch Linux official and AUR web interface binding +description: + Arch Linux official and AUR web interface binding. + See README for details. + +category: Web +license: MIT +license-file: LICENSE +author: berberman +maintainer: berberman +copyright: Copyright (c) berberman 2021 +stability: alpha +homepage: https://github.com/berberman/arch-web +bug-reports: https://github.com/berberman/arch-web/issues +extra-doc-files: + CHANGELOG.md + README.md + +tested-with: + GHC ==8.8.3 || ==8.8.4 || ==8.10.1 || ==8.10.2 || ==8.10.3 + +common common + build-depends: + , aeson ^>=1.5.4 + , base >=4.10 && <5 + , deriving-aeson ^>=0.2.6 + , exceptions ^>=0.10.4 + , http-client ^>=0.6.4 + , http-client-tls ^>=0.3.5 + , http-types ^>=0.12.3 + , lens ^>=4.19.2 + , mtl ^>=2.2.2 + , servant ^>=0.18.2 + , servant-client ^>=0.18.2 + , servant-client-core ^>=0.18.2 + , text ^>=1.2.3 + , time ^>=1.9.3 + + default-language: Haskell2010 + ghc-options: + -Wall -Wcompat -Widentities -Wincomplete-uni-patterns + -Wincomplete-record-updates + + if impl(ghc >=8.0) + ghc-options: -Wredundant-constraints + + if impl(ghc >=8.2) + ghc-options: -fhide-source-paths + + if impl(ghc >=8.4) + ghc-options: -Wmissing-export-lists + + if impl(ghc >=8.8) + ghc-options: -Wmissing-deriving-strategies + + default-extensions: + NoStarIsType + ConstraintKinds + DataKinds + DeriveAnyClass + DeriveFunctor + DeriveGeneric + DerivingStrategies + DerivingVia + FlexibleContexts + FlexibleInstances + FunctionalDependencies + KindSignatures + LambdaCase + OverloadedStrings + RecordWildCards + ScopedTypeVariables + TypeApplications + TypeFamilies + TypeOperators + ViewPatterns + +library + import: common + exposed-modules: + Web.ArchLinux + Web.ArchLinux.API + Web.ArchLinux.Types + Web.ArchLinux.Types.Lens + + other-modules: Web.ArchLinux.Types.API + hs-source-dirs: src + +test-suite arch-web-test + import: common + type: exitcode-stdio-1.0 + build-depends: arch-web, HUnit + hs-source-dirs: test + main-is: Main.hs + +source-repository head + type: git + location: https://github.com/berberman/arch-web diff --git a/src/Web/ArchLinux.hs b/src/Web/ArchLinux.hs new file mode 100644 --- /dev/null +++ b/src/Web/ArchLinux.hs @@ -0,0 +1,14 @@ +-- | Copyright: (c) 2021 berberman +-- SPDX-License-Identifier: MIT +-- Maintainer: berberman +-- Stability: experimental +-- Portability: portable +-- Arch Linux official repositories web interfaces and AUR web interfaces. +module Web.ArchLinux + ( module Web.ArchLinux.Types, + module Web.ArchLinux.API, + ) +where + +import Web.ArchLinux.API +import Web.ArchLinux.Types diff --git a/src/Web/ArchLinux/API.hs b/src/Web/ArchLinux/API.hs new file mode 100644 --- /dev/null +++ b/src/Web/ArchLinux/API.hs @@ -0,0 +1,217 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +-- | Copyright: (c) 2021 berberman +-- SPDX-License-Identifier: MIT +-- Maintainer: berberman +-- Stability: experimental +-- Portability: portable +-- Arch Linux official repositories APIs and AUR APIs. +-- +-- These two kinds of APIs are distinguished by 'APIClient'. +-- Functions over them return 'APIClient' parametrize by corresponding 'APIType'. +-- +-- Overall, there are five APIs available, +-- refer to and . +module Web.ArchLinux.API + ( -- * API Client + APIClient (..), + APIType (..), + HasBaseUrl (..), + runAPIClient, + runAPIClient', + + -- * Arch Linux official + SearchOptions (..), + emptySearchOptions, + getPackageDetails, + getPackageFiles, + searchPackage, + + -- * AUR + AurSearchType (..), + searchAur, + getAurInfo, + ) +where + +import Control.Monad.Catch (MonadCatch, MonadThrow) +import Control.Monad.Except (MonadError) +import Control.Monad.IO.Class (MonadIO) +import Control.Monad.Reader (MonadReader) +import Data.Aeson (FromJSON, Result (..), Value, fromJSON) +import Data.Proxy +import Data.Text (Text) +import qualified Data.Text as T +import GHC.Generics (Generic) +import Network.HTTP.Client (Manager) +import Network.HTTP.Client.TLS (newTlsManager) +import Network.HTTP.Types (http11) +import Servant.Client +import Servant.Client.Core (RunClient, throwClientError) +import Web.ArchLinux.Types +import Web.ArchLinux.Types.API + +-- | Two types of APIs. +data APIType = ArchLinux | Aur + +-- | A wrapper of 'ClientM', with 'BaseUrl' reflected to type level phantom 'APIType'. +newtype APIClient (k :: APIType) a = APIClient {unWrapClientM :: ClientM a} + deriving newtype + ( Functor, + Applicative, + Monad, + MonadIO, + Generic, + MonadReader ClientEnv, + MonadError ClientError, + MonadThrow, + MonadCatch + ) + deriving (RunClient) via ClientM + +-- | Class to reify 'BaseUrl' from 'APIType'. +class HasBaseUrl (k :: APIType) where + getBaseUrl :: BaseUrl + +instance HasBaseUrl 'ArchLinux where + getBaseUrl = BaseUrl Https "www.archlinux.org" 443 "" + +instance HasBaseUrl 'Aur where + getBaseUrl = BaseUrl Https "aur.archlinux.org" 443 "" + +-- | Runs 'APIClient'. +-- +-- It calls 'getBaseUrl', then creates 'ClientEnv', finally calls 'runClientM'. +runAPIClient :: forall s a. HasBaseUrl s => Manager -> APIClient s a -> IO (Either ClientError a) +runAPIClient manager m = runClientM (unWrapClientM m) $ mkClientEnv manager $ getBaseUrl @s + +-- | Like 'runAPIClient', but creates a 'Manager'. +runAPIClient' :: HasBaseUrl s => APIClient s a -> IO (Either ClientError a) +runAPIClient' m = newTlsManager >>= flip runAPIClient m + +----------------------------------------------------------------------------- + +-- | Options available in searching packages in Arch Linux official repositories. +-- +-- See 'searchPackage'. +data SearchOptions = SearchOptions + { _nameOrDescription :: Maybe Text, + _exactName :: Maybe Text, + _targetDescription :: Maybe Text, + _targetRepositories :: [Repo], + _targetArchitectures :: [Arch], + _targetMaintianer :: Maybe Text, + _targetPackager :: Maybe Text, + _isFlagged :: Maybe Flagged + } + deriving stock (Generic, Eq, Ord, Show) + +-- | An empty options value for convenient. +-- +-- For example, +-- +-- > let options = +-- > emptySearchOptions +-- > & nameOrDescription ?~ "kea" +-- > & targetRepositories .~ [Community, CommunityTesting] +-- > searchPackage options +-- +-- searchs packages whose names or descriptions contain @kea@, from @Community@ or @Community-Testing@. +emptySearchOptions :: SearchOptions +emptySearchOptions = SearchOptions Nothing Nothing Nothing [] [] Nothing Nothing Nothing + +-- | Gets details of an exact package. +getPackageDetails :: + -- | official repository + Repo -> + -- | arch + Arch -> + -- | exact name + Text -> + APIClient 'ArchLinux PackageInformation +getPackageDetails r a p = APIClient $ client (Proxy @GetPackageDetails) r a p + +-- | Gets files list of an exact package. +getPackageFiles :: + -- | official repository + Repo -> + -- | arch + Arch -> + -- | exact name + Text -> + APIClient 'ArchLinux PackageFiles +getPackageFiles r a p = APIClient $ client (Proxy @GetPackageFiles) r a p + +-- | Searches packages. +-- +-- See 'SearchOptions' and 'emptySearchOptions'. +searchPackage :: SearchOptions -> APIClient 'ArchLinux (ArchLinuxResponse PackageInformation) +searchPackage SearchOptions {..} = + let f = client (Proxy @SearchPackage) + in APIClient $ + f + _nameOrDescription + _exactName + _targetDescription + _targetRepositories + _targetArchitectures + _targetMaintianer + _targetPackager + _isFlagged + +----------------------------------------------------------------------------- + +-- | Searches packages in AUR by what? +data AurSearchType + = ByName + | ByNameOrDesc + | ByMaintainer + | ByDepends + | ByMakedepends + | ByOptdepends + | ByCheckdepends + deriving stock (Generic, Eq, Ord, Enum, Show) + +searchTypeToValue :: AurSearchType -> Text +searchTypeToValue = \case + ByName -> "name" + ByNameOrDesc -> "name-desc" + ByMaintainer -> "maintainer" + ByDepends -> "depends" + ByMakedepends -> "makedepends" + ByOptdepends -> "optdepends" + ByCheckdepends -> "checkdepends" + +aurRPC :: Text -> Maybe Text -> [Text] -> ClientM Value +aurRPC = client (Proxy @AurRPC) 5 + +-- This is evil and cheating!! +-- Use this to report delayed json decode error in 'HttpClientError' +dummyResponse :: Response +dummyResponse = Response (toEnum 0) mempty http11 "dummy response for error display" + +parseResult :: (FromJSON a) => Value -> ClientM a +parseResult v = case fromJSON v of + Success x -> pure x + Data.Aeson.Error err -> throwClientError $ DecodeFailure (T.pack err) dummyResponse + +-- | Searches packages in AUR. +searchAur :: + -- | search type + AurSearchType -> + -- | search argument + Text -> + APIClient 'Aur (AurResponse [AurSearch]) +searchAur (searchTypeToValue -> f) arg = APIClient $ do + result <- aurRPC "search" (Just f) [arg] + parseResult result + +-- | Gets details of a set of packages in AUR. +getAurInfo :: + -- | exact names + [Text] -> + APIClient 'Aur (AurResponse [AurInfo]) +getAurInfo exactNames = APIClient $ do + result <- aurRPC "info" Nothing exactNames + parseResult result diff --git a/src/Web/ArchLinux/Types.hs b/src/Web/ArchLinux/Types.hs new file mode 100644 --- /dev/null +++ b/src/Web/ArchLinux/Types.hs @@ -0,0 +1,335 @@ +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE StandaloneDeriving #-} + +-- | Copyright: (c) 2021 berberman +-- SPDX-License-Identifier: MIT +-- Maintainer: berberman +-- Stability: experimental +-- Portability: portable +-- This module defines types and their serializations used in API. +-- +-- Fields' names are prefixed with @_@ for lenses generation, +-- consider using "Web.ArchLinux.Types.Lens" to access data types smoothly. +module Web.ArchLinux.Types + ( -- * Arch Linux official + Repo (..), + Arch (..), + License (..), + PackageInformation (..), + PackageFiles (..), + Flagged (..), + ArchLinuxResponse (..), + + -- * AUR + AurSearch (..), + AurInfo (..), + AurResponseType (..), + AurResponse (..), + ) +where + +import Data.Aeson +import Data.Char (toUpper) +import Data.Maybe (fromJust, fromMaybe) +import Data.Text (Text) +import qualified Data.Text as T +import Data.Time (UTCTime) +import Deriving.Aeson +import Servant.API (ToHttpApiData (..)) + +type ArchLinuxJSON = CustomJSON '[FieldLabelModifier (StripPrefix "_", CamelToSnake)] + +unString :: Value -> Text +unString (String x) = x +unString _ = undefined + +toQueryParamViaJSON :: ToJSON a => a -> Text +toQueryParamViaJSON = unString . fromJust . decode . encode + +data AurModifier + +instance StringModifier AurModifier where + getStringModifier (T.pack -> t) = T.unpack $ eat "Url" "URL" $ eat "Id" "ID" upper + where + upper = + case T.uncons t of + Just (h, s) -> T.cons (toUpper h) s + _ -> error "impossible" + eat prefix to input = case T.stripPrefix prefix input of + Just x -> to <> x + _ -> input + +type AurJSON = CustomJSON '[FieldLabelModifier (StripPrefix "_", AurModifier)] + +----------------------------------------------------------------------------- + +-- | Official repositories. +data Repo + = Core + | Extra + | Testing + | Multilib + | MultilibTesting + | Community + | CommunityTesting + deriving stock (Show, Eq, Ord, Enum, Generic) + deriving (FromJSON, ToJSON) via CustomJSON '[ConstructorTagModifier CamelToKebab] Repo + +instance ToHttpApiData Repo where + toQueryParam (toQueryParamViaJSON -> x) = case T.breakOn "-" x of + (T.uncons -> Just (h, s), "") -> T.cons (toUpper h) s + (T.uncons -> Just (h1, s1), T.uncons -> Just ('-', T.uncons -> Just (h2, s2))) -> + T.cons (toUpper h1) s1 <> "-" <> T.cons (toUpper h2) s2 + _ -> undefined + +-- | Official architectures. +data Arch + = Any + | I686 + | X86_64 + deriving stock (Show, Eq, Ord, Enum, Generic) + deriving (FromJSON, ToJSON) via CustomJSON '[ConstructorTagModifier CamelToSnake] Arch + +instance ToHttpApiData Arch where + toQueryParam = toQueryParamViaJSON + +-- | Liceses defined in . +data License + = AGPL3 + | Apache + | Artistic2_0 + | CDDL + | CPL + | EPL + | FDL1_2 + | FDL1_3 + | GPL2 + | GPL3 + | LGPL2_1 + | LGPL3 + | LPPL + | MPL + | MPL2 + | PHP + | PSF + | PerlArtistic + | RUBY + | Unlicense + | W3C + | ZPL + | Custom Text + deriving stock (Show, Eq, Ord, Generic) + +licenseJSONOption :: Options +licenseJSONOption = + defaultOptions + { fieldLabelModifier = T.unpack . T.replace "_" "." . T.pack, + sumEncoding = UntaggedValue + } + +instance ToJSON License where + toJSON (Custom x) = String $ "custom: " <> x + toJSON x = + genericToJSON licenseJSONOption x + +instance FromJSON License where + parseJSON = withText "License" $ \txt -> do + case T.stripPrefix "custom:" txt of + Just c -> pure $ Custom c + _ -> genericParseJSON licenseJSONOption (String $ T.stripStart txt) + +-- | Package details returned by 'Web.ArchLinux.API.getPackageDetails'. +data PackageInformation = PackageInformation + { _pkgname :: Text, + _pkgbase :: Text, + _repo :: Repo, + _arch :: Arch, + _pkgver :: Text, + _pkgrel :: Text, + _epoch :: Int, + _pkgdesc :: Text, + _url :: Text, + _filename :: Text, + _compressedSize :: Int, + _installedSize :: Int, + _buildDate :: UTCTime, + _lastUpdate :: UTCTime, + _flageDate :: Maybe UTCTime, + _maintainers :: [Text], + _packager :: Text, + _groups :: [Text], + _licenses :: [License], + _conflicts :: [Text], + _provides :: [Text], + _replaces :: [Text], + _depends :: [Text], + _optdepends :: [Text], + _makedepends :: [Text], + _checkdepends :: [Text] + } + deriving stock (Show, Eq, Ord, Generic) + deriving (FromJSON, ToJSON) via ArchLinuxJSON PackageInformation + +-- | Package files list returned by 'Web.ArchLinux.API.getPackageFiles' +data PackageFiles = PackageFiles + { _pkgname :: Text, + _repo :: Repo, + _arch :: Arch, + _pkgLastUpdate :: UTCTime, + _filesLastUpdate :: UTCTime, + _filesCount :: Int, + _dirCount :: Int, + _files :: [FilePath] + } + deriving stock (Show, Eq, Ord, Generic) + deriving (FromJSON, ToJSON) via ArchLinuxJSON PackageFiles + +-- | Flagged package means out-of-date. +data Flagged = Flagged | NotFlagged + deriving stock (Show, Eq, Ord, Enum, Generic) + +instance ToHttpApiData Flagged where + toQueryParam Flagged = "Flagged" + toQueryParam NotFlagged = "Not+Flagged" + +-- | Response data type of 'Web.ArchLinux.API.searchPackage'. +data ArchLinuxResponse a = ArchLinuxResponse + { _version :: Int, + _limit :: Int, + _valid :: Bool, + _results :: [a] + } + deriving stock (Show, Eq, Ord, Functor, Generic) + +deriving via ArchLinuxJSON (ArchLinuxResponse a) instance (FromJSON a) => FromJSON (ArchLinuxResponse a) + +deriving via ArchLinuxJSON (ArchLinuxResponse a) instance (ToJSON a) => ToJSON (ArchLinuxResponse a) + +----------------------------------------------------------------------------- + +-- | Search results returned by 'Web.ArchLinux.API.searchAur'. +-- +-- Some of fileds are renamed in this record type, for sharing +-- overloaded lenses between data type returned by Arch Linux official API. +data AurSearch = AurSearch + { _id :: Int, + _name :: Text, + _packageBaseID :: Int, + _packageBase :: Text, + _version :: Text, + _description :: Maybe Text, + -- | URL + _url :: Maybe Text, + _numVotes :: Int, + _popularity :: Double, + -- | UTCTime + _outOfDate :: Maybe Int, + _maintainer :: Maybe Text, + -- | UTCTime + _firstSubmitted :: Int, + -- | UTCTime + _lastModified :: Int, + _urlPath :: Text + } + deriving stock (Show, Eq, Ord, Generic) + deriving (FromJSON, ToJSON) via AurJSON AurSearch + +-- | Package details returned by 'Web.ArchLinux.API.getAurInfo'. +-- +-- This data type extends 'AurSearch' informally, +-- so it includes '_search' as a member. +data AurInfo = AurInfo + { -- | ID, Name, PackageBaseID, ... + _search :: AurSearch, + -- | Depends + _depends :: [Text], + -- | MakeDepends + _makedepends :: [Text], + -- | OptDepends + _optdepends :: [Text], + -- | CheckDepends + _checkdepends :: [Text], + _conflicts :: [Text], + _provides :: [Text], + _replaces :: [Text], + _groups :: [Text], + _licenses :: [License], + _keywords :: [Text] + } + deriving stock (Show, Eq, Ord, Generic) + +instance FromJSON AurInfo where + parseJSON = withObject "AurInfo" $ \o -> do + _search <- parseJSON $ Object o + _depends <- fromMaybe [] <$> o .:? "Depends" + _makedepends <- fromMaybe [] <$> o .:? "MakeDepends" + _optdepends <- fromMaybe [] <$> o .:? "OptDepends" + _checkdepends <- fromMaybe [] <$> o .:? "CheckDepends" + _conflicts <- fromMaybe [] <$> o .:? "Conflicts" + _provides <- fromMaybe [] <$> o .:? "Provides" + _replaces <- fromMaybe [] <$> o .:? "Replaces" + _groups <- fromMaybe [] <$> o .:? "Groups" + _licenses <- fromMaybe [] <$> o .:? "License" + _keywords <- fromMaybe [] <$> o .:? "Keywords" + pure AurInfo {..} + +instance ToJSON AurInfo where + toJSON AurInfo {..} = + Object $ + unObject (toJSON _search) + <> unObject + ( object + [ "Depends" .= _depends, + "MakeDepends" .= _makedepends, + "OptDepends" .= _optdepends, + "CheckDepends" .= _checkdepends, + "Conflicts" .= _conflicts, + "Provides" .= _provides, + "Replaces" .= _replaces, + "Groups" .= _groups, + "License" .= _licenses, + "Keywords" .= _keywords + ] + ) + where + unObject (Object o) = o + unObject _ = error "impossible" + +-- | Return types of AUR API. +data AurResponseType = Search | Multiinfo | Error + deriving stock (Show, Eq, Ord, Enum, Generic) + deriving (FromJSON, ToJSON) via CustomJSON '[ConstructorTagModifier CamelToSnake] AurResponseType + +-- | Response data type of AUR API. +data AurResponse a = AurResponse + { _version :: Int, + -- | type + _aurType :: AurResponseType, + -- | resultcount + _resultCount :: Int, + _results :: a, + -- | Available when 'aurType' equals to 'AurResponseType.Error'. + _error :: Maybe Text + } + deriving stock (Show, Eq, Ord, Functor, Generic) + +instance (FromJSON a) => FromJSON (AurResponse a) where + parseJSON = withObject "AurResponse" $ \o -> do + _version <- o .: "version" + _aurType <- o .: "type" + _resultCount <- o .: "resultcount" + _results <- o .: "results" + _error <- o .:? "error" + pure AurResponse {..} + +instance (ToJSON a) => ToJSON (AurResponse a) where + toJSON AurResponse {..} = + object $ + [ "version" .= _version, + "type" .= _aurType, + "resultcount" .= _resultCount, + "results" .= _results + ] + <> case _error of + Just err -> ["error" .= err] + _ -> [] diff --git a/src/Web/ArchLinux/Types/API.hs b/src/Web/ArchLinux/Types/API.hs new file mode 100644 --- /dev/null +++ b/src/Web/ArchLinux/Types/API.hs @@ -0,0 +1,50 @@ +{-# OPTIONS_HADDOCK hide, prune #-} + +module Web.ArchLinux.Types.API + ( module Web.ArchLinux.Types.API, + ) +where + +import Data.Aeson (Value) +import Data.Text (Text) +import Servant.API +import Web.ArchLinux.Types + +type GetPackageDetails = + "packages" + :> Capture "repository" Repo + :> Capture "architecture" Arch + :> Capture "package" Text + :> "json" + :> Get '[JSON] PackageInformation + +type GetPackageFiles = + "packages" + :> Capture "repository" Repo + :> Capture "architecture" Arch + :> Capture "package" Text + :> "files" + :> "json" + :> Get '[JSON] PackageFiles + +type SearchPackage = + "packages" + :> "search" + :> "json" + :> QueryParam "q" Text + :> QueryParam "name" Text + :> QueryParam "desc" Text + :> QueryParams "repo" Repo + :> QueryParams "arch" Arch + :> QueryParam "maintainer" Text + :> QueryParam "packager" Text + :> QueryParam "flagged" Flagged + :> Get '[JSON] (ArchLinuxResponse PackageInformation) + +type AurRPC = + "rpc" + :> QueryParam' '[Strict, Required] "v" Int + :> QueryParam' '[Strict, Required] "type" Text + :> QueryParam "by" Text + :> QueryParams "arg" Text + :> Get '[JSON] Value diff --git a/src/Web/ArchLinux/Types/Lens.hs b/src/Web/ArchLinux/Types/Lens.hs new file mode 100644 --- /dev/null +++ b/src/Web/ArchLinux/Types/Lens.hs @@ -0,0 +1,26 @@ +{-# LANGUAGE TemplateHaskell #-} + +-- | Copyright: (c) 2021 berberman +-- SPDX-License-Identifier: MIT +-- Maintainer: berberman +-- Stability: experimental +-- Portability: portable +-- Lenses. +module Web.ArchLinux.Types.Lens + ( module Web.ArchLinux.Types.Lens, + ) +where + +import Control.Lens.TH (makeFieldsNoPrefix, makeLenses) +import Web.ArchLinux.API +import Web.ArchLinux.Types + +makeFieldsNoPrefix ''PackageInformation +makeFieldsNoPrefix ''PackageFiles +makeFieldsNoPrefix ''ArchLinuxResponse + +makeFieldsNoPrefix ''AurSearch +makeFieldsNoPrefix ''AurInfo +makeFieldsNoPrefix ''AurResponse + +makeLenses ''SearchOptions diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -0,0 +1,28 @@ +module Main (main) where + +import Network.HTTP.Client (Manager) +import Network.HTTP.Client.TLS (newTlsManager) +import Test.HUnit +import Web.ArchLinux + +main :: IO () +main = do + manager <- newTlsManager + runTestTTAndExit $ tests manager + +tests :: Manager -> Test +tests manager = + TestList + [ createTest "getPackageDetails" manager $ getPackageDetails Core X86_64 "linux", + createTest "getPackageFiles" manager $ getPackageFiles Core X86_64 "linux", + createTest "searchPackage" manager $ searchPackage emptySearchOptions {_nameOrDescription = Just "linux"}, + createTest "searchAur" manager $ searchAur ByNameOrDesc "haskell", + createTest "getAurInfo" manager $ getAurInfo ["arch-hs-git"] + ] + +createTest :: HasBaseUrl k => String -> Manager -> APIClient k a -> Test +createTest tag manager action = TestLabel tag . TestCase $ do + result <- runAPIClient manager action + case result of + Right _ -> pure () + Left err -> assertFailure $ show err