diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,20 +1,20 @@ -Copyright (c) 2015 Harry Garrood - -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. +Copyright (c) 2015 Harry Garrood + +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/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -1,2 +1,2 @@ -import Distribution.Simple -main = defaultMain +import Distribution.Simple +main = defaultMain diff --git a/bower-json.cabal b/bower-json.cabal --- a/bower-json.cabal +++ b/bower-json.cabal @@ -1,59 +1,59 @@ -name: bower-json -version: 1.0.0.1 -synopsis: Read bower.json from Haskell -license: MIT -license-file: LICENSE -author: Harry Garrood -maintainer: harry@garrood.me -homepage: https://github.com/hdgarrood/bower-json -category: Web -build-type: Simple -cabal-version: >=1.10 - -description: - Bower is a package manager for the web (see ). - - This package provides a data type and ToJSON/FromJSON instances for Bower's - package manifest file, bower.json. - -extra-source-files: - test-resources/bower.json - -source-repository head - type: git - location: https://github.com/hdgarrood/bower-json - -library - exposed-modules: Web.Bower.PackageMeta - other-modules: Web.Bower.PackageMeta.Internal - build-depends: base >=4 && <5 - , ghc-prim - , aeson >=0.6.1.0 - , deepseq - , aeson-better-errors >= 0.5 - , unordered-containers - , text - , bytestring - , scientific - , vector - , transformers - , mtl - - ghc-options: -Wall - hs-source-dirs: src - default-language: Haskell2010 - -test-suite tests - type: exitcode-stdio-1.0 - main-is: Main.hs - hs-source-dirs: test - build-depends: base >=4 && <5 - , bower-json -any - , aeson -any - , bytestring -any - , text -any - , unordered-containers -any - , tasty -any - , tasty-hunit -any - ghc-options: -Wall -fno-warn-missing-signatures - default-language: Haskell2010 +name: bower-json +version: 1.1.0.0 +synopsis: Read bower.json from Haskell +license: MIT +license-file: LICENSE +author: Harry Garrood +maintainer: harry@garrood.me +homepage: https://github.com/hdgarrood/bower-json +category: Web +build-type: Simple +cabal-version: >=1.10 + +description: + Bower is a package manager for the web (see ). + + This package provides a data type and ToJSON/FromJSON instances for Bower's + package manifest file, bower.json. + +extra-source-files: + test-resources/bower.json + +source-repository head + type: git + location: https://github.com/hdgarrood/bower-json + +library + exposed-modules: Web.Bower.PackageMeta + other-modules: Web.Bower.PackageMeta.Internal + build-depends: base >=4.14.3.0 && <5 + , ghc-prim + , aeson >=2.0.1.0 + , deepseq + , aeson-better-errors >= 0.5 + , unordered-containers + , text + , bytestring + , scientific + , vector + , transformers + , mtl + + ghc-options: -Wall + hs-source-dirs: src + default-language: Haskell2010 + +test-suite tests + type: exitcode-stdio-1.0 + main-is: Main.hs + hs-source-dirs: test + build-depends: base >=4 && <5 + , bower-json -any + , aeson -any + , bytestring -any + , text -any + , unordered-containers -any + , tasty -any + , tasty-hunit -any + ghc-options: -Wall -fno-warn-missing-signatures + default-language: Haskell2010 diff --git a/src/Web/Bower/PackageMeta.hs b/src/Web/Bower/PackageMeta.hs --- a/src/Web/Bower/PackageMeta.hs +++ b/src/Web/Bower/PackageMeta.hs @@ -1,35 +1,35 @@ - --- | A data type representing the Bower.json package description file, together --- with a parser and related functions. --- --- This code is based on the specification at --- . - -module Web.Bower.PackageMeta - ( - -- * Data types - PackageMeta(..) - , PackageName - , runPackageName - , mkPackageName - , Author(..) - , ModuleType(..) - , moduleTypes - , Repository(..) - , Version(..) - , VersionRange(..) - , BowerError(..) - , showBowerError - , PackageNameError(..) - , showPackageNameError - -- * Parsing - , decodeFile - , displayError - , asPackageMeta - , parseModuleType - , parsePackageName - , asAuthor - , asRepository - ) where - -import Web.Bower.PackageMeta.Internal + +-- | A data type representing the Bower.json package description file, together +-- with a parser and related functions. +-- +-- This code is based on the specification at +-- . + +module Web.Bower.PackageMeta + ( + -- * Data types + PackageMeta(..) + , PackageName + , runPackageName + , mkPackageName + , Author(..) + , ModuleType(..) + , moduleTypes + , Repository(..) + , Version(..) + , VersionRange(..) + , BowerError(..) + , showBowerError + , PackageNameError(..) + , showPackageNameError + -- * Parsing + , decodeFile + , displayError + , asPackageMeta + , parseModuleType + , parsePackageName + , asAuthor + , asRepository + ) where + +import Web.Bower.PackageMeta.Internal diff --git a/src/Web/Bower/PackageMeta/Internal.hs b/src/Web/Bower/PackageMeta/Internal.hs --- a/src/Web/Bower/PackageMeta/Internal.hs +++ b/src/Web/Bower/PackageMeta/Internal.hs @@ -1,365 +1,362 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveGeneric #-} - --- | A data type representing the Bower.json package description file, together --- with a parser and related functions. --- --- This code is based on the specification at --- . - -module Web.Bower.PackageMeta.Internal where - -#if !MIN_VERSION_base(4,8,0) -import Control.Applicative (pure, (<$>), (<*>)) -#endif -import Control.Monad -import Control.Category ((>>>)) -import Control.Monad.Error.Class (MonadError(..)) -import Control.DeepSeq -import GHC.Generics -import Data.Monoid -import Data.Char -import Data.Text (Text) -import qualified Data.Text as T -import qualified Data.ByteString.Lazy as B - -import Data.Aeson ((.=)) -import qualified Data.Aeson as A -import qualified Data.Aeson.Types as Aeson -import Data.Aeson.BetterErrors (Parse, ParseError, asText, asString, asBool, eachInArray, eachInObjectWithKey, withText, key, keyMay, keyOrDefault, toAesonParser', toAesonParser, displayError, parse) - ---------------------- --- Data types - --- | A data type representing the data stored in a bower.json package manifest --- file. --- --- Note that the 'ToJSON' / 'FromJSON' instances don't exactly match; for --- example, it is not always the case that decoding from JSON and then encoding --- to JSON will give you the exact same JSON that you started with. However, if --- you start with a PackageMeta value, encode to JSON, and then decode, you --- should always get the same value back. -data PackageMeta = PackageMeta - { bowerName :: PackageName - , bowerDescription :: Maybe Text - , bowerMain :: [FilePath] - , bowerModuleType :: [ModuleType] - , bowerLicense :: [Text] - , bowerIgnore :: [Text] - , bowerKeywords :: [Text] - , bowerAuthors :: [Author] - , bowerHomepage :: Maybe Text - , bowerRepository :: Maybe Repository - , bowerDependencies :: [(PackageName, VersionRange)] - , bowerDevDependencies :: [(PackageName, VersionRange)] - , bowerResolutions :: [(PackageName, Version)] - , bowerPrivate :: Bool - } - deriving (Show, Eq, Ord, Generic) - -instance NFData PackageMeta - --- | A valid package name for a Bower package. -newtype PackageName - = PackageName Text - deriving (Show, Eq, Ord, Generic) - -instance NFData PackageName - -runPackageName :: PackageName -> Text -runPackageName (PackageName s) = s - --- | A smart constructor for a PackageName. It ensures that the package name --- satisfies the restrictions described at --- . -mkPackageName :: Text -> Either PackageNameError PackageName -mkPackageName = fmap PackageName . validateAll validators - where - dashOrDot = ['-', '.'] - validateAll vs x = mapM_ (validateWith x) vs >> return x - validateWith x (p, err) - | p x = Right x - | otherwise = Left (err x) - validChar c = isAscii c && (isLower c || isDigit c || c `elem` dashOrDot) - validators = - [ (not . T.null, const NotEmpty) - , (T.all validChar, InvalidChars . T.unpack . T.filter (not . validChar)) - , (firstChar (`notElem` dashOrDot), const MustNotBeginSeparator) - , (lastChar (`notElem` dashOrDot), const MustNotEndSeparator) - , (not . T.isInfixOf "--", const RepeatedSeparators) - , (not . T.isInfixOf "..", const RepeatedSeparators) - , (T.length >>> (<= 50), TooLong . T.length) - ] - firstChar p str = not (T.null str) && p (T.index str 0) - lastChar p = firstChar p . T.reverse - -data Author = Author - { authorName :: Text - , authorEmail :: Maybe Text - , authorHomepage :: Maybe Text - } - deriving (Show, Eq, Ord, Generic) - -instance NFData Author - --- | See: -data ModuleType - = Globals - | AMD - | Node - | ES6 - | YUI - deriving (Show, Eq, Ord, Enum, Bounded, Generic) - -instance NFData ModuleType - -moduleTypes :: [(Text, ModuleType)] -moduleTypes = map (\t -> (T.toLower (T.pack (show t)), t)) [minBound .. maxBound] - -data Repository = Repository - { repositoryUrl :: Text - , repositoryType :: Text - } - deriving (Show, Eq, Ord, Generic) - -instance NFData Repository - -newtype Version - = Version { runVersion :: Text } - deriving (Show, Eq, Ord, Generic) - -instance NFData Version - -newtype VersionRange - = VersionRange { runVersionRange :: Text } - deriving (Show, Eq, Ord, Generic) - -instance NFData VersionRange - -data BowerError - = InvalidPackageName PackageNameError - | InvalidModuleType Text - deriving (Show, Eq, Ord, Generic) - -instance NFData BowerError - -showBowerError :: BowerError -> Text -showBowerError (InvalidPackageName err) = - "Invalid package name: " <> showPackageNameError err -showBowerError (InvalidModuleType str) = - "Invalid module type: " <> str <> - ". Must be one of: " <> renderList moduleTypes - where - renderList = - map (T.pack . show . fst) - >>> T.intercalate ", " - -data PackageNameError - = NotEmpty - | TooLong Int - | InvalidChars [Char] - | RepeatedSeparators - | MustNotBeginSeparator - | MustNotEndSeparator - deriving (Show, Eq, Ord, Generic) - -instance NFData PackageNameError - -showPackageNameError :: PackageNameError -> Text -showPackageNameError err = case err of - NotEmpty -> - "A package name may not be empty" - TooLong x -> - "Package names must be no more than 50 characters, yours was " <> - T.pack (show x) - InvalidChars chars -> - "The following characters are not permitted in package names: " <> - T.intercalate " " (map T.singleton chars) - RepeatedSeparators -> - "The substrings \"--\" and \"..\" may not appear in "<> - "package names" - MustNotBeginSeparator -> - "Package names may not begin with a dash or a dot" - MustNotEndSeparator -> - "Package names may not end with a dash or a dot" - -displayError :: ParseError BowerError -> Text -displayError = T.unlines . Data.Aeson.BetterErrors.displayError showBowerError - -------------------------- --- Parsing - --- | Read and attempt to decode a bower.json file. -decodeFile :: FilePath -> IO (Either (ParseError BowerError) PackageMeta) -decodeFile = fmap (parse asPackageMeta) . B.readFile - --- | A parser for bower.json files, using the aeson-better-errors package. -asPackageMeta :: Parse BowerError PackageMeta -asPackageMeta = - PackageMeta <$> key "name" (withText parsePackageName) - <*> keyMay "description" asText - <*> keyOrDefault "main" [] (arrayOrSingle asString) - <*> keyOrDefault "moduleType" [] (arrayOrSingle (withText parseModuleType)) - <*> keyOrDefault "license" [] (arrayOrSingle asText) - <*> keyOrDefault "ignore" [] (eachInArray asText) - <*> keyOrDefault "keywords" [] (eachInArray asText) - <*> keyOrDefault "authors" [] (eachInArray asAuthor) - <*> keyMay "homepage" asText - <*> keyMay "repository" asRepository - <*> keyOrDefault "dependencies" [] (asAssocListOf VersionRange) - <*> keyOrDefault "devDependencies" [] (asAssocListOf VersionRange) - <*> keyOrDefault "resolutions" [] (asAssocListOf Version) - <*> keyOrDefault "private" False asBool - where - arrayOrSingle :: Parse e a -> Parse e [a] - arrayOrSingle parser = - (fmap (:[]) parser) <|> eachInArray parser - where - (<|>) p q = catchError p (const q) - - asAssocListOf :: (Text -> a) -> Parse BowerError [(PackageName, a)] - asAssocListOf g = - eachInObjectWithKey parsePackageName (g <$> asText) - -parseModuleType :: Text -> Either BowerError ModuleType -parseModuleType str = - case lookup str moduleTypes of - Nothing -> Left (InvalidModuleType str) - Just mt -> Right mt - -parsePackageName :: Text -> Either BowerError PackageName -parsePackageName str = - case mkPackageName str of - Left err -> Left (InvalidPackageName err) - Right n -> Right n - -asAuthor :: Parse e Author -asAuthor = catchError asAuthorString (const asAuthorObject) - -asAuthorString :: Parse e Author -asAuthorString = withText $ \s -> - let (email, s1) = takeDelim "<" ">" (T.words s) - (homepage, s2) = takeDelim "(" ")" s1 - in pure (Author (T.unwords s2) email homepage) - --- | Given a prefix and a suffix, go through the supplied list, attempting --- to extract one string from the list which has the given prefix and suffix, --- All other strings in the list are returned as the second component of the --- tuple. -takeDelim :: Text -> Text -> [Text] -> (Maybe Text, [Text]) -takeDelim start end = foldr go (Nothing, []) - where - go str (Just x, strs) = - (Just x, str : strs) - go str (Nothing, strs) = - case stripWrapper start end str of - Just str' -> (Just str', strs) - Nothing -> (Nothing, str : strs) - --- | Like stripPrefix, but strips a suffix as well. -stripWrapper :: Text -> Text -> Text -> Maybe Text -stripWrapper start end = - T.stripPrefix start - >>> fmap T.reverse - >=> T.stripPrefix (T.reverse end) - >>> fmap T.reverse - -asAuthorObject :: Parse e Author -asAuthorObject = - Author <$> key "name" asText - <*> keyMay "email" asText - <*> keyMay "homepage" asText - -asRepository :: Parse e Repository -asRepository = - Repository <$> key "url" asText - <*> key "type" asText - ------------------------- --- Serializing - -instance A.ToJSON PackageMeta where - toJSON PackageMeta{..} = - A.object $ concat - [ [ "name" .= bowerName ] - , maybePair "description" bowerDescription - , maybeArrayPair "main" bowerMain - , maybeArrayPair "moduleType" bowerModuleType - , maybeArrayPair "license" bowerLicense - , maybeArrayPair "ignore" bowerIgnore - , maybeArrayPair "keywords" bowerKeywords - , maybeArrayPair "authors" bowerAuthors - , maybePair "homepage" bowerHomepage - , maybePair "repository" bowerRepository - , assoc "dependencies" bowerDependencies - , assoc "devDependencies" bowerDevDependencies - , assoc "resolutions" bowerResolutions - , if bowerPrivate then [ "private" .= True ] else [] - ] - - where - assoc :: A.ToJSON a => Text -> [(PackageName, a)] -> [Aeson.Pair] - assoc = maybeArrayAssocPair runPackageName - -instance A.ToJSON PackageName where - toJSON = A.toJSON . runPackageName - -instance A.ToJSON ModuleType where - toJSON = A.toJSON . map toLower . show - -instance A.ToJSON Repository where - toJSON Repository{..} = - A.object [ "url" .= repositoryUrl - , "type" .= repositoryType - ] - -instance A.ToJSON Author where - toJSON Author{..} = - A.object $ - [ "name" .= authorName ] ++ - maybePair "email" authorEmail ++ - maybePair "homepage" authorHomepage - -instance A.ToJSON Version where - toJSON = A.toJSON . runVersion - -instance A.ToJSON VersionRange where - toJSON = A.toJSON . runVersionRange - -maybePair :: A.ToJSON a => Text -> Maybe a -> [Aeson.Pair] -maybePair k = maybe [] (\val -> [k .= val]) - -maybeArrayPair :: A.ToJSON a => Text -> [a] -> [Aeson.Pair] -maybeArrayPair _ [] = [] -maybeArrayPair k xs = [k .= xs] - -maybeArrayAssocPair :: A.ToJSON b => (a -> Text) -> Text -> [(a,b)] -> [Aeson.Pair] -maybeArrayAssocPair _ _ [] = [] -maybeArrayAssocPair f k xs = [k .= A.object (map (\(k', v) -> f k' .= v) xs)] - -------------------------- --- FromJSON instances - -instance A.FromJSON PackageMeta where - parseJSON = toAesonParser showBowerError asPackageMeta - -instance A.FromJSON PackageName where - parseJSON = toAesonParser showBowerError (withText parsePackageName) - -instance A.FromJSON ModuleType where - parseJSON = toAesonParser showBowerError (withText parseModuleType) - -instance A.FromJSON Repository where - parseJSON = toAesonParser' asRepository - -instance A.FromJSON Author where - parseJSON = toAesonParser' asAuthor - -instance A.FromJSON Version where - parseJSON = toAesonParser' (Version <$> asText) - -instance A.FromJSON VersionRange where - parseJSON = toAesonParser' (VersionRange <$> asText) +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveGeneric #-} + +-- | A data type representing the Bower.json package description file, together +-- with a parser and related functions. +-- +-- This code is based on the specification at +-- . + +module Web.Bower.PackageMeta.Internal where + +import Control.Monad +import Control.Category ((>>>)) +import Control.Monad.Error.Class (MonadError(..)) +import Control.DeepSeq +import GHC.Generics +import Data.Char +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.ByteString.Lazy as B + +import Data.Aeson ((.=)) +import qualified Data.Aeson as A +import qualified Data.Aeson.Key as A.Key +import qualified Data.Aeson.Types as Aeson +import Data.Aeson.BetterErrors (Parse, ParseError, asText, asString, asBool, eachInArray, eachInObjectWithKey, withText, key, keyMay, keyOrDefault, toAesonParser', toAesonParser, displayError, parse) + +--------------------- +-- Data types + +-- | A data type representing the data stored in a bower.json package manifest +-- file. +-- +-- Note that the 'ToJSON' / 'FromJSON' instances don't exactly match; for +-- example, it is not always the case that decoding from JSON and then encoding +-- to JSON will give you the exact same JSON that you started with. However, if +-- you start with a PackageMeta value, encode to JSON, and then decode, you +-- should always get the same value back. +data PackageMeta = PackageMeta + { bowerName :: PackageName + , bowerDescription :: Maybe Text + , bowerMain :: [FilePath] + , bowerModuleType :: [ModuleType] + , bowerLicense :: [Text] + , bowerIgnore :: [Text] + , bowerKeywords :: [Text] + , bowerAuthors :: [Author] + , bowerHomepage :: Maybe Text + , bowerRepository :: Maybe Repository + , bowerDependencies :: [(PackageName, VersionRange)] + , bowerDevDependencies :: [(PackageName, VersionRange)] + , bowerResolutions :: [(PackageName, Version)] + , bowerPrivate :: Bool + } + deriving (Show, Eq, Ord, Generic) + +instance NFData PackageMeta + +-- | A valid package name for a Bower package. +newtype PackageName + = PackageName Text + deriving (Show, Eq, Ord, Generic) + +instance NFData PackageName + +runPackageName :: PackageName -> Text +runPackageName (PackageName s) = s + +-- | A smart constructor for a PackageName. It ensures that the package name +-- satisfies the restrictions described at +-- . +mkPackageName :: Text -> Either PackageNameError PackageName +mkPackageName = fmap PackageName . validateAll validators + where + dashOrDot = ['-', '.'] + validateAll vs x = mapM_ (validateWith x) vs >> return x + validateWith x (p, err) + | p x = Right x + | otherwise = Left (err x) + validChar c = isAscii c && (isLower c || isDigit c || c `elem` dashOrDot) + validators = + [ (not . T.null, const NotEmpty) + , (T.all validChar, InvalidChars . T.unpack . T.filter (not . validChar)) + , (firstChar (`notElem` dashOrDot), const MustNotBeginSeparator) + , (lastChar (`notElem` dashOrDot), const MustNotEndSeparator) + , (not . T.isInfixOf "--", const RepeatedSeparators) + , (not . T.isInfixOf "..", const RepeatedSeparators) + , (T.length >>> (<= 50), TooLong . T.length) + ] + firstChar p str = not (T.null str) && p (T.index str 0) + lastChar p = firstChar p . T.reverse + +data Author = Author + { authorName :: Text + , authorEmail :: Maybe Text + , authorHomepage :: Maybe Text + } + deriving (Show, Eq, Ord, Generic) + +instance NFData Author + +-- | See: +data ModuleType + = Globals + | AMD + | Node + | ES6 + | YUI + deriving (Show, Eq, Ord, Enum, Bounded, Generic) + +instance NFData ModuleType + +moduleTypes :: [(Text, ModuleType)] +moduleTypes = map (\t -> (T.toLower (T.pack (show t)), t)) [minBound .. maxBound] + +data Repository = Repository + { repositoryUrl :: Text + , repositoryType :: Text + } + deriving (Show, Eq, Ord, Generic) + +instance NFData Repository + +newtype Version + = Version { runVersion :: Text } + deriving (Show, Eq, Ord, Generic) + +instance NFData Version + +newtype VersionRange + = VersionRange { runVersionRange :: Text } + deriving (Show, Eq, Ord, Generic) + +instance NFData VersionRange + +data BowerError + = InvalidPackageName PackageNameError + | InvalidModuleType Text + deriving (Show, Eq, Ord, Generic) + +instance NFData BowerError + +showBowerError :: BowerError -> Text +showBowerError (InvalidPackageName err) = + "Invalid package name: " <> showPackageNameError err +showBowerError (InvalidModuleType str) = + "Invalid module type: " <> str <> + ". Must be one of: " <> renderList moduleTypes + where + renderList = + map (T.pack . show . fst) + >>> T.intercalate ", " + +data PackageNameError + = NotEmpty + | TooLong Int + | InvalidChars [Char] + | RepeatedSeparators + | MustNotBeginSeparator + | MustNotEndSeparator + deriving (Show, Eq, Ord, Generic) + +instance NFData PackageNameError + +showPackageNameError :: PackageNameError -> Text +showPackageNameError err = case err of + NotEmpty -> + "A package name may not be empty" + TooLong x -> + "Package names must be no more than 50 characters, yours was " <> + T.pack (show x) + InvalidChars chars -> + "The following characters are not permitted in package names: " <> + T.intercalate " " (map T.singleton chars) + RepeatedSeparators -> + "The substrings \"--\" and \"..\" may not appear in "<> + "package names" + MustNotBeginSeparator -> + "Package names may not begin with a dash or a dot" + MustNotEndSeparator -> + "Package names may not end with a dash or a dot" + +displayError :: ParseError BowerError -> Text +displayError = T.unlines . Data.Aeson.BetterErrors.displayError showBowerError + +------------------------- +-- Parsing + +-- | Read and attempt to decode a bower.json file. +decodeFile :: FilePath -> IO (Either (ParseError BowerError) PackageMeta) +decodeFile = fmap (parse asPackageMeta) . B.readFile + +-- | A parser for bower.json files, using the aeson-better-errors package. +asPackageMeta :: Parse BowerError PackageMeta +asPackageMeta = + PackageMeta <$> key "name" (withText parsePackageName) + <*> keyMay "description" asText + <*> keyOrDefault "main" [] (arrayOrSingle asString) + <*> keyOrDefault "moduleType" [] (arrayOrSingle (withText parseModuleType)) + <*> keyOrDefault "license" [] (arrayOrSingle asText) + <*> keyOrDefault "ignore" [] (eachInArray asText) + <*> keyOrDefault "keywords" [] (eachInArray asText) + <*> keyOrDefault "authors" [] (eachInArray asAuthor) + <*> keyMay "homepage" asText + <*> keyMay "repository" asRepository + <*> keyOrDefault "dependencies" [] (asAssocListOf VersionRange) + <*> keyOrDefault "devDependencies" [] (asAssocListOf VersionRange) + <*> keyOrDefault "resolutions" [] (asAssocListOf Version) + <*> keyOrDefault "private" False asBool + where + arrayOrSingle :: Parse e a -> Parse e [a] + arrayOrSingle parser = + (fmap (:[]) parser) <|> eachInArray parser + where + (<|>) p q = catchError p (const q) + + asAssocListOf :: (Text -> a) -> Parse BowerError [(PackageName, a)] + asAssocListOf g = + eachInObjectWithKey parsePackageName (g <$> asText) + +parseModuleType :: Text -> Either BowerError ModuleType +parseModuleType str = + case lookup str moduleTypes of + Nothing -> Left (InvalidModuleType str) + Just mt -> Right mt + +parsePackageName :: Text -> Either BowerError PackageName +parsePackageName str = + case mkPackageName str of + Left err -> Left (InvalidPackageName err) + Right n -> Right n + +asAuthor :: Parse e Author +asAuthor = catchError asAuthorString (const asAuthorObject) + +asAuthorString :: Parse e Author +asAuthorString = withText $ \s -> + let (email, s1) = takeDelim "<" ">" (T.words s) + (homepage, s2) = takeDelim "(" ")" s1 + in pure (Author (T.unwords s2) email homepage) + +-- | Given a prefix and a suffix, go through the supplied list, attempting +-- to extract one string from the list which has the given prefix and suffix, +-- All other strings in the list are returned as the second component of the +-- tuple. +takeDelim :: Text -> Text -> [Text] -> (Maybe Text, [Text]) +takeDelim start end = foldr go (Nothing, []) + where + go str (Just x, strs) = + (Just x, str : strs) + go str (Nothing, strs) = + case stripWrapper start end str of + Just str' -> (Just str', strs) + Nothing -> (Nothing, str : strs) + +-- | Like stripPrefix, but strips a suffix as well. +stripWrapper :: Text -> Text -> Text -> Maybe Text +stripWrapper start end = + T.stripPrefix start + >>> fmap T.reverse + >=> T.stripPrefix (T.reverse end) + >>> fmap T.reverse + +asAuthorObject :: Parse e Author +asAuthorObject = + Author <$> key "name" asText + <*> keyMay "email" asText + <*> keyMay "homepage" asText + +asRepository :: Parse e Repository +asRepository = + Repository <$> key "url" asText + <*> key "type" asText + +------------------------ +-- Serializing + +instance A.ToJSON PackageMeta where + toJSON PackageMeta{..} = + A.object $ concat + [ [ "name" .= bowerName ] + , maybePair "description" bowerDescription + , maybeArrayPair "main" bowerMain + , maybeArrayPair "moduleType" bowerModuleType + , maybeArrayPair "license" bowerLicense + , maybeArrayPair "ignore" bowerIgnore + , maybeArrayPair "keywords" bowerKeywords + , maybeArrayPair "authors" bowerAuthors + , maybePair "homepage" bowerHomepage + , maybePair "repository" bowerRepository + , assoc "dependencies" bowerDependencies + , assoc "devDependencies" bowerDevDependencies + , assoc "resolutions" bowerResolutions + , if bowerPrivate then [ "private" .= True ] else [] + ] + + where + assoc :: A.ToJSON a => A.Key -> [(PackageName, a)] -> [Aeson.Pair] + assoc = maybeArrayAssocPair (A.Key.fromText . runPackageName) + +instance A.ToJSON PackageName where + toJSON = A.toJSON . runPackageName + +instance A.ToJSON ModuleType where + toJSON = A.toJSON . map toLower . show + +instance A.ToJSON Repository where + toJSON Repository{..} = + A.object [ "url" .= repositoryUrl + , "type" .= repositoryType + ] + +instance A.ToJSON Author where + toJSON Author{..} = + A.object $ + [ "name" .= authorName ] ++ + maybePair "email" authorEmail ++ + maybePair "homepage" authorHomepage + +instance A.ToJSON Version where + toJSON = A.toJSON . runVersion + +instance A.ToJSON VersionRange where + toJSON = A.toJSON . runVersionRange + +maybePair :: A.ToJSON a => A.Key -> Maybe a -> [Aeson.Pair] +maybePair k = maybe [] (\val -> [k .= val]) + +maybeArrayPair :: A.ToJSON a => A.Key -> [a] -> [Aeson.Pair] +maybeArrayPair _ [] = [] +maybeArrayPair k xs = [k .= xs] + +maybeArrayAssocPair :: A.ToJSON b => (a -> A.Key) -> A.Key -> [(a,b)] -> [Aeson.Pair] +maybeArrayAssocPair _ _ [] = [] +maybeArrayAssocPair f k xs = [k .= A.object (map (\(k', v) -> f k' .= v) xs)] + +------------------------- +-- FromJSON instances + +instance A.FromJSON PackageMeta where + parseJSON = toAesonParser showBowerError asPackageMeta + +instance A.FromJSON PackageName where + parseJSON = toAesonParser showBowerError (withText parsePackageName) + +instance A.FromJSON ModuleType where + parseJSON = toAesonParser showBowerError (withText parseModuleType) + +instance A.FromJSON Repository where + parseJSON = toAesonParser' asRepository + +instance A.FromJSON Author where + parseJSON = toAesonParser' asAuthor + +instance A.FromJSON Version where + parseJSON = toAesonParser' (Version <$> asText) + +instance A.FromJSON VersionRange where + parseJSON = toAesonParser' (VersionRange <$> asText) diff --git a/test-resources/bower.json b/test-resources/bower.json --- a/test-resources/bower.json +++ b/test-resources/bower.json @@ -1,23 +1,23 @@ -{ - "name": "purescript-prelude", - "homepage": "https://github.com/purescript/purescript-prelude", - "description": "The PureScript Prelude", - "keywords": [ - "purescript" - ], - "license": "MIT", - "repository": { - "type": "git", - "url": "git://github.com/purescript/purescript-prelude.git" - }, - "ignore": [ - "**/.*", - "bower_components", - "node_modules", - "output", - "test", - "bower.json", - "gulpfile.js", - "package.json" - ] -} +{ + "name": "purescript-prelude", + "homepage": "https://github.com/purescript/purescript-prelude", + "description": "The PureScript Prelude", + "keywords": [ + "purescript" + ], + "license": "MIT", + "repository": { + "type": "git", + "url": "git://github.com/purescript/purescript-prelude.git" + }, + "ignore": [ + "**/.*", + "bower_components", + "node_modules", + "output", + "test", + "bower.json", + "gulpfile.js", + "package.json" + ] +} diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -1,139 +1,138 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} - -import Test.Tasty -import Test.Tasty.HUnit - -import Control.Monad -import Data.Monoid -import Data.Aeson -import qualified Data.ByteString.Lazy as B - -import Web.Bower.PackageMeta - --- Decode any JSON value, not just arrays/objects. --- this is a bit of a hack, but the 'proper' way is just too much effort. -decodeValue :: FromJSON a => B.ByteString -> Maybe a -decodeValue = the <=< decode . ("[" <>) . (<> "]") - where - the [x] = Just x - the _ = Nothing - -main :: IO () -main = defaultMain tests - -tests :: TestTree -tests = testGroup "tests" - [ testGroup "FromJSON Author instance" authorTests - , testGroup "optional keys" optionalKeyTests - , testGroup "round trips" roundTripTests - , testGroup "real bower.json" realBowerJsonTests - ] - -authorTests :: [TestTree] -authorTests = - [ testCase "As string without homepage/email" $ do - Just authorWithoutOptionalAttrs @=? - decodeValue "\"Harry Garrood\"" - - -- should not be sensitive to extra whitespace - Just authorWithoutOptionalAttrs @=? - decodeValue "\" Harry Garrood \"" - - , testCase "As string with homepage/email" $ do - Just authorWithEmail @=? - decodeValue "\"Harry Garrood \"" - - Just authorWithHomepage @=? - decodeValue "\"Harry Garrood (http://harry.garrood.me)\"" - - Just authorWithBoth @=? - decodeValue "\"Harry Garrood (http://harry.garrood.me)\"" - - , testCase "As object" $ do - Just authorWithoutOptionalAttrs @=? - decode "{\"name\": \"Harry Garrood\"}" - - Just authorWithEmail @=? - decode "{\"name\": \"Harry Garrood\", \"email\": \"harry@garrood.me\"}" - - Just authorWithHomepage @=? - decode "{\"name\": \"Harry Garrood\", \"homepage\": \"http://harry.garrood.me\"}" - - Just authorWithBoth @=? - decode "{\"name\": \"Harry Garrood\", \"email\": \"harry@garrood.me\", \"homepage\": \"http://harry.garrood.me\"}" - ] - -authorWithoutOptionalAttrs = Author "Harry Garrood" Nothing Nothing -authorWithEmail = Author "Harry Garrood" (Just "harry@garrood.me") Nothing -authorWithHomepage = Author "Harry Garrood" Nothing (Just "http://harry.garrood.me") -authorWithBoth = Author "Harry Garrood" (Just "harry@garrood.me") (Just "http://harry.garrood.me") - -optionalKeyTests :: [TestTree] -optionalKeyTests = - [ testCase "Missing keys should become empty lists, missing private key means not private" $ do - Just basic @=? decode "{\"name\": \"test-package\"}" - - , testCase "Empty objects should turn into empty lists" $ do - Just basic @=? decode "{\"name\": \"test-package\", \"dependencies\": {}}" - - , testCase "Nonempty objects should be parsed" $ do - Just basicWithDeps @=? - decode "{\"name\": \"test-package\", \"dependencies\": {\"dependency-package\": \">= 1.0\"}}" - - , testCase "Empty arrays should be parsed as empty lists" $ do - Just basic @=? decode "{\"name\": \"test-package\", \"main\": []}" - - , testCase "Arrays with values should be parsed" $ do - Just basicWithModuleType @=? - decode "{\"name\": \"test-package\", \"moduleType\": [\"amd\"]}" - ] - where - -Right pkgName = mkPackageName "test-package" -Right depPkgName = mkPackageName "dependency-package" -basic = PackageMeta pkgName Nothing [] [] [] [] [] [] Nothing Nothing [] [] [] False -basicWithDeps = basic { bowerDependencies = [(depPkgName, VersionRange ">= 1.0")] } -basicWithModuleType = basic { bowerModuleType = [AMD] } - -complex = - basicWithDeps - { bowerDescription = Just "hello, world" - , bowerMain = ["foo.js"] - , bowerModuleType = [Globals, Node] - , bowerLicense = ["MIT"] - , bowerIgnore = [] - , bowerKeywords = ["purescript"] - , bowerAuthors = [authorWithoutOptionalAttrs, authorWithEmail, authorWithBoth] - , bowerHomepage = Nothing - , bowerRepository = Just (Repository "git://github.com/hdgarrood/test-package" "git") - , bowerDevDependencies = [] - , bowerResolutions = [] - } - -complexPrivate = complex { bowerPrivate = True } - -allPkgs = - [ ("basic", basic) - , ("basicWithDeps", basicWithDeps) - , ("basicWithModuleType", basicWithModuleType) - , ("complex", complex) - , ("complexPrivate", complexPrivate) - ] - -roundTripTests :: [TestTree] -roundTripTests = - map (\(name, b) -> testCase name (Just b @=? decode (encode b))) - allPkgs - -realBowerJsonTests :: [TestTree] -realBowerJsonTests = [go] - where - go = - testCase "parses a real bower.json correctly" $ do - res <- decodeFile "./test-resources/bower.json" - case res of - Right PackageMeta{..} -> - ["MIT"] @=? bowerLicense - Left err -> - assertBool ("Failed to parse ./test-resources/bower.json: " ++ show err) False +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +import Test.Tasty +import Test.Tasty.HUnit + +import Control.Monad +import Data.Aeson +import qualified Data.ByteString.Lazy as B + +import Web.Bower.PackageMeta + +-- Decode any JSON value, not just arrays/objects. +-- this is a bit of a hack, but the 'proper' way is just too much effort. +decodeValue :: FromJSON a => B.ByteString -> Maybe a +decodeValue = the <=< decode . ("[" <>) . (<> "]") + where + the [x] = Just x + the _ = Nothing + +main :: IO () +main = defaultMain tests + +tests :: TestTree +tests = testGroup "tests" + [ testGroup "FromJSON Author instance" authorTests + , testGroup "optional keys" optionalKeyTests + , testGroup "round trips" roundTripTests + , testGroup "real bower.json" realBowerJsonTests + ] + +authorTests :: [TestTree] +authorTests = + [ testCase "As string without homepage/email" $ do + Just authorWithoutOptionalAttrs @=? + decodeValue "\"Harry Garrood\"" + + -- should not be sensitive to extra whitespace + Just authorWithoutOptionalAttrs @=? + decodeValue "\" Harry Garrood \"" + + , testCase "As string with homepage/email" $ do + Just authorWithEmail @=? + decodeValue "\"Harry Garrood \"" + + Just authorWithHomepage @=? + decodeValue "\"Harry Garrood (http://harry.garrood.me)\"" + + Just authorWithBoth @=? + decodeValue "\"Harry Garrood (http://harry.garrood.me)\"" + + , testCase "As object" $ do + Just authorWithoutOptionalAttrs @=? + decode "{\"name\": \"Harry Garrood\"}" + + Just authorWithEmail @=? + decode "{\"name\": \"Harry Garrood\", \"email\": \"harry@garrood.me\"}" + + Just authorWithHomepage @=? + decode "{\"name\": \"Harry Garrood\", \"homepage\": \"http://harry.garrood.me\"}" + + Just authorWithBoth @=? + decode "{\"name\": \"Harry Garrood\", \"email\": \"harry@garrood.me\", \"homepage\": \"http://harry.garrood.me\"}" + ] + +authorWithoutOptionalAttrs = Author "Harry Garrood" Nothing Nothing +authorWithEmail = Author "Harry Garrood" (Just "harry@garrood.me") Nothing +authorWithHomepage = Author "Harry Garrood" Nothing (Just "http://harry.garrood.me") +authorWithBoth = Author "Harry Garrood" (Just "harry@garrood.me") (Just "http://harry.garrood.me") + +optionalKeyTests :: [TestTree] +optionalKeyTests = + [ testCase "Missing keys should become empty lists, missing private key means not private" $ do + Just basic @=? decode "{\"name\": \"test-package\"}" + + , testCase "Empty objects should turn into empty lists" $ do + Just basic @=? decode "{\"name\": \"test-package\", \"dependencies\": {}}" + + , testCase "Nonempty objects should be parsed" $ do + Just basicWithDeps @=? + decode "{\"name\": \"test-package\", \"dependencies\": {\"dependency-package\": \">= 1.0\"}}" + + , testCase "Empty arrays should be parsed as empty lists" $ do + Just basic @=? decode "{\"name\": \"test-package\", \"main\": []}" + + , testCase "Arrays with values should be parsed" $ do + Just basicWithModuleType @=? + decode "{\"name\": \"test-package\", \"moduleType\": [\"amd\"]}" + ] + where + +Right pkgName = mkPackageName "test-package" +Right depPkgName = mkPackageName "dependency-package" +basic = PackageMeta pkgName Nothing [] [] [] [] [] [] Nothing Nothing [] [] [] False +basicWithDeps = basic { bowerDependencies = [(depPkgName, VersionRange ">= 1.0")] } +basicWithModuleType = basic { bowerModuleType = [AMD] } + +complex = + basicWithDeps + { bowerDescription = Just "hello, world" + , bowerMain = ["foo.js"] + , bowerModuleType = [Globals, Node] + , bowerLicense = ["MIT"] + , bowerIgnore = [] + , bowerKeywords = ["purescript"] + , bowerAuthors = [authorWithoutOptionalAttrs, authorWithEmail, authorWithBoth] + , bowerHomepage = Nothing + , bowerRepository = Just (Repository "git://github.com/hdgarrood/test-package" "git") + , bowerDevDependencies = [] + , bowerResolutions = [] + } + +complexPrivate = complex { bowerPrivate = True } + +allPkgs = + [ ("basic", basic) + , ("basicWithDeps", basicWithDeps) + , ("basicWithModuleType", basicWithModuleType) + , ("complex", complex) + , ("complexPrivate", complexPrivate) + ] + +roundTripTests :: [TestTree] +roundTripTests = + map (\(name, b) -> testCase name (Just b @=? decode (encode b))) + allPkgs + +realBowerJsonTests :: [TestTree] +realBowerJsonTests = [go] + where + go = + testCase "parses a real bower.json correctly" $ do + res <- decodeFile "./test-resources/bower.json" + case res of + Right PackageMeta{..} -> + ["MIT"] @=? bowerLicense + Left err -> + assertBool ("Failed to parse ./test-resources/bower.json: " ++ show err) False