{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE CPP #-}
module Elm2Nix.PackagesSnapshot
( snapshot
) where
import Control.Monad (liftM2, liftM3)
import qualified Data.Aeson as Aeson
import qualified Data.Binary as Binary
import Data.Binary (Binary, put, get, putWord8, getWord8)
import qualified Data.Map as Map
#if MIN_VERSION_req(2,0,0)
#else
import Data.Default (def)
#endif
import Data.Map (Map)
import Data.Text (Text)
import qualified Data.Text as Text
import Data.Word (Word16)
import qualified Network.HTTP.Req as Req
import System.FilePath ((</>))
data Name =
Name
{ _author :: !Text
, _project :: !Text
}
deriving (Eq, Ord)
data Package =
Package
{ _name :: !Name
, _version :: !Version
}
deriving (Eq, Ord)
data Version =
Version
{ _major :: {-# UNPACK #-} !Word16
, _minor :: {-# UNPACK #-} !Word16
, _patch :: {-# UNPACK #-} !Word16
}
deriving (Eq, Ord)
data PackageRegistry =
PackageRegistry Int (Map Name [Version])
instance Binary Name where
get =
liftM2 Name get get
put (Name author project) =
do put author
put project
instance Binary Package where
get =
liftM2 Package get get
put (Package name version) =
do put name
put version
instance Binary Version where
get =
do word <- getWord8
if word == 0
then liftM3 Version get get get
else
do minor <- fmap fromIntegral getWord8
patch <- fmap fromIntegral getWord8
return (Version (fromIntegral word) minor patch)
put (Version major minor patch) =
if major < 256 && minor < 256 && patch < 256 then
do putWord8 (fromIntegral major)
putWord8 (fromIntegral minor)
putWord8 (fromIntegral patch)
else
do putWord8 0
put major
put minor
put patch
instance Binary PackageRegistry where
get = liftM2 PackageRegistry get get
put (PackageRegistry a b) = put a >> put b
#if MIN_VERSION_req(2,0,0)
defHttpConfig = Req.defaultHttpConfig
#else
defHttpConfig = def
#endif
snapshot :: String -> IO ()
snapshot dir = do
r <- Req.runReq defHttpConfig $
Req.req
Req.POST
(Req.https "package.elm-lang.org" Req./: "all-packages")
Req.NoReqBody
Req.jsonResponse
mempty
let packages = unwrap $ case Aeson.fromJSON (Req.responseBody r) of
Aeson.Error s -> error s
Aeson.Success val -> val
size = Map.foldr ((+) . length) 0 packages
registry = PackageRegistry size packages
Binary.encodeFile (dir </> "versions.dat") registry
newtype Packages = Packages { unwrap :: Map.Map Name [Version] }
instance Aeson.FromJSON Packages where
parseJSON v = Packages <$> Aeson.parseJSON v
instance Aeson.FromJSON Version where
parseJSON = Aeson.withText "string" $ \x ->
case Text.splitOn "." x of
[major, minor, patch] ->
return $ Version
(read (Text.unpack major))
(read (Text.unpack minor))
(read (Text.unpack patch))
_ ->
fail "failure parsing version"
instance Aeson.FromJSON Name where
parseJSON = Aeson.withText "string" $ \x ->
case Text.splitOn "/" x of
[author, package] -> return $ Name author package
lst -> fail $ "wrong package name: " <> show lst
instance Aeson.FromJSONKey Name where
fromJSONKey = Aeson.FromJSONKeyTextParser $ \x ->
case Text.splitOn "/" x of
[author, package] -> return $ Name author package
lst -> fail $ "wrong package name: " <> show lst