From 92531045f80cda81b3953683b10965769ab81f52 Mon Sep 17 00:00:00 2001 From: Julian Ospald Date: Thu, 16 Jan 2020 23:27:38 +0100 Subject: [PATCH] Basic version of 'downloadURL' --- README.md | 33 ++++++ TODO.md | 12 ++ cabal.project | 7 ++ ghcup.cabal | 11 +- lib/GHCup.hs | 233 +++++++++++++++++++++++++------------- lib/GHCup/Bash.hs | 75 ++++++------ lib/GHCup/File.hs | 56 +++------ lib/GHCup/Prelude.hs | 30 ++++- lib/GHCup/Types.hs | 64 +++++++---- lib/GHCup/Types/Foo.hs | 18 --- lib/GHCup/Types/JSON.hs | 43 +++---- lib/GHCup/Types/Optics.hs | 11 ++ 12 files changed, 355 insertions(+), 238 deletions(-) create mode 100644 TODO.md delete mode 100644 lib/GHCup/Types/Foo.hs diff --git a/README.md b/README.md index ebbff20..364759a 100644 --- a/README.md +++ b/README.md @@ -1 +1,34 @@ # ghcup + +A rewrite of ghcup in haskell. This can be used as a library +and may be redistributed as a binary in the future. + +## Motivation + +ghcup has increasingly become difficult to maintain. A few reasons: + +* few maintainers +* increasing LOC +* platform incompatibilities regularly causing breaking bugs: + * [Mktemp not working properly on macOS](https://gitlab.haskell.org/haskell/ghcup/issues/130) + * [ln: illegal option -- T on macOS Catalina](https://gitlab.haskell.org/haskell/ghcup/issues/123) + * [Wrong tar flag on darwin](https://gitlab.haskell.org/haskell/ghcup/issues/119)) +* refactoring being difficult due to POSIX sh + +More benefits of a rewrite: + +* Features such as installing [release candidates](https://gitlab.haskell.org/haskell/ghcup/issues/94) or [HEAD builds](https://gitlab.haskell.org/haskell/ghcup/issues/65) can be more conveniently implemented in a rewrite +* Refactoring will be easier +* Better tool support (such as linting the downloads file) +* saner downloads file format (such as JSON) + +However, the downside will be: + +* building static binaries for all platforms (and possibly causing SSL/DNS problems) +* still bootstrapping those binaries via a POSIX sh script + +## Goals + +* Correct low-level code +* Good exception handling +* Easier user interface (possibly interactive and non-interactive ones) diff --git a/TODO.md b/TODO.md new file mode 100644 index 0000000..a5a589f --- /dev/null +++ b/TODO.md @@ -0,0 +1,12 @@ +# TODOs and Remarks + +* handling of SIGTERM and SIGUSR +* add support for RC/alpha/HEAD versions +* redo/rethink how tool tags works +* installing multiple versions in parallel? + +* exception handling (checked exception library? Maybe effects system all the way?) +* how to version and extend the format of the downloads file? Compatibility? +* how to propagate updates? Automatically? Might solve the versioning problem + + diff --git a/cabal.project b/cabal.project index d9ca9c0..43ff2ca 100644 --- a/cabal.project +++ b/cabal.project @@ -1,2 +1,9 @@ packages: ./ghcup.cabal +optimization: 2 + +package streamly + ghc-options: -O2 -fspec-constr-recursive=16 -fmax-worker-args=16 + +package ghcup + ghc-options: -O2 -fspec-constr-recursive=16 -fmax-worker-args=16 diff --git a/ghcup.cabal b/ghcup.cabal index 878cea7..582186c 100644 --- a/ghcup.cabal +++ b/ghcup.cabal @@ -20,6 +20,7 @@ source-repository head type: git location: https://github.com/hasufell/ghcup-hs +common aeson { build-depends: aeson >= 1.4 } common ascii-string { build-depends: ascii-string >= 1.0 } common base { build-depends: base >= 4.12.0.0 && < 5 } common bytestring { build-depends: bytestring >= 0.10 } @@ -36,12 +37,16 @@ common streamly { build-depends: streamly >= 0.7 } common strict-base { build-depends: strict-base >= 0.4 } common template-haskell { build-depends: template-haskell >= 2.7 } common text { build-depends: text >= 1.2 } +common text-icu { build-depends: text-icu >= 0.7 } common transformers { build-depends: transformers >= 0.5 } common unix { build-depends: unix >= 2.7 } common url { build-depends: url >= 2.1 } common utf8-string { build-depends: utf8-string >= 1.0 } common vector { build-depends: vector >= 0.12 } common waargonaut { build-depends: waargonaut >= 0.8 } +common async { build-depends: async >= 0.8 } +common mtl { build-depends: mtl >= 2.2 } +common versions { build-depends: versions >= 3.5 } common config @@ -53,7 +58,9 @@ library import: config , base -- deps + , aeson , ascii-string + , async , bytestring , containers , generics-sop @@ -61,6 +68,7 @@ library , hpath-filepath , hpath-io , language-bash + , mtl , optics , parsec , safe-exceptions @@ -68,12 +76,13 @@ library , strict-base , template-haskell , text + , text-icu , transformers , unix , url , utf8-string , vector - , waargonaut + , versions exposed-modules: GHCup GHCup.Bash GHCup.File diff --git a/lib/GHCup.hs b/lib/GHCup.hs index 362a7a4..df55aa5 100644 --- a/lib/GHCup.hs +++ b/lib/GHCup.hs @@ -10,44 +10,46 @@ -- TODO: handle SIGTERM, SIGUSR module GHCup where + import Control.Applicative -import Data.Strict.Maybe -import Data.Version -import GHCup.Prelude +import Control.Monad +import Data.Foldable ( asum ) +import Data.Text ( Text ) +import Data.Versions import GHCup.Bash import GHCup.File +import GHCup.Prelude import GHCup.Types import GHCup.Types.Optics import HPath import HPath.IO import Network.URL -import qualified Data.ByteString.Lazy.UTF8 as UTF8 import Optics import Prelude hiding ( abs - , Maybe - , Just - , Nothing + , readFile ) import System.Info - +import qualified Data.Text as T +import qualified Data.Text.ICU as ICU +import Data.Maybe ( isJust ) import qualified Data.Map.Strict as Map -import qualified GHC.Exts as GE -import qualified Prelude as P -import qualified System.Posix.Process.ByteString - as SPPB - availableDownloads :: AvailableDownloads availableDownloads = Map.fromList [ ( GHC , Map.fromList - [ ( mkV [8, 6, 5] + [ ( (\(Right x) -> x) $ version (fS "8.6.5") , Map.fromList [ ( A_64 , Map.fromList [ ( Linux UnknownLinux - , mkGHCUrl "~ghc/8.6.5/ghc-8.6.5-x86_64-fedora27-linux.tar.xz" + , Map.fromList + [ ( Nothing + , mkGHCUrl + "~ghc/8.6.5/ghc-8.6.5-x86_64-fedora27-linux.tar.xz" + ) + ] ) ] ) @@ -57,101 +59,170 @@ availableDownloads = Map.fromList ) ] where - mkV = makeVersion mkGHCUrl path = URL - { url_type = Absolute $ Host (HTTP True) "downloads.haskell.org" P.Nothing + { url_type = Absolute $ Host (HTTP True) "downloads.haskell.org" Nothing , url_path = path , url_params = [] } -downloadURL :: Tool - -> Version - -> Architecture - -> Platform - -> AvailableDownloads - -> Maybe URL -downloadURL t v a p dls = with_distro <|> without_ver <|> without_distro + +downloadURL :: ToolRequest + -> Maybe PlatformRequest + -> URLSource + -> IO (Maybe URL) -- TODO: better error handling +downloadURL (ToolRequest t v) mpfReq urlSource = do + (PlatformRequest arch plat ver) <- case mpfReq of + Just x -> pure x + Nothing -> do + (PlatformResult rp rv) <- getPlatform + let ar = (\(Right x) -> x) getArchitecture + pure $ PlatformRequest ar rp rv + + dls <- case urlSource of + GHCupURL -> fail "Not implemented" + OwnSource url -> fail "Not implemented" + OwnSpec dls -> pure dls + + pure $ downloadURL' t v arch plat ver dls + + +downloadURL' :: Tool + -> Version + -- ^ tool version + -> Architecture + -- ^ user arch + -> Platform + -- ^ user platform + -> Maybe Versioning + -- ^ optional version of the platform + -> AvailableDownloads + -> Maybe URL +downloadURL' t v a p mv dls = + with_distro <|> without_distro_ver <|> without_distro where - with_distro = distro_preview id - without_distro = distro_preview withoutDistro - without_ver = distro_preview withoutVer + with_distro = distro_preview id id + without_distro = distro_preview (set _Linux UnknownLinux) id + without_distro_ver = distro_preview id (const Nothing) - distro_preview f = - toStrictMaybe $ preview (atJust t % atJust v % atJust a % atJust (f p)) dls + distro_preview f g = + preview (atJust t % atJust v % atJust a % atJust (f p) % atJust (g mv)) dls atJust x = at x % _Just - -- | If we can't find a version with the given distro, - -- then just try with the platform. - withoutDistro :: Platform -> Platform - withoutDistro (Linux _) = Linux UnknownLinux - withoutDistro Darwin = Darwin - withoutDistro (FreeBSD _) = FreeBSD Nothing - -- | If we can't find a match with the given distro version, - -- we gotta try without it. - withoutVer :: Platform -> Platform - withoutVer (Linux (Debian _) ) = Linux $ Debian Nothing - withoutVer (Linux (Ubuntu _) ) = Linux $ Ubuntu Nothing - withoutVer (Linux (Mint _) ) = Linux $ Mint Nothing - withoutVer (Linux (Fedora _) ) = Linux $ Fedora Nothing - withoutVer (Linux UnknownLinux) = Linux $ UnknownLinux - withoutVer Darwin = Darwin - withoutVer (FreeBSD _) = FreeBSD Nothing - - -getArchitecture :: IO Architecture +getArchitecture :: Either String Architecture getArchitecture = case arch of "x86_64" -> pure A_64 "i386" -> pure A_32 - what -> fail ("Could not find compatible architecture. Was: " <> what) + what -> Left ("Could not find compatible architecture. Was: " <> what) -getPlatform :: IO Platform +getPlatform :: IO PlatformResult getPlatform = case os of "linux" -> do - distro <- getLinuxDistro - pure $ Linux distro + (distro, ver) <- getLinuxDistro + pure $ PlatformResult { _platform = Linux distro, _distroVersion = ver } -- TODO: these are not verified - "darwin" -> pure $ Darwin + "darwin" -> + pure $ PlatformResult { _platform = Darwin, _distroVersion = Nothing } "freebsd" -> do ver <- getFreeBSDVersion - pure $ FreeBSD ver + pure $ PlatformResult { _platform = FreeBSD, _distroVersion = ver } what -> fail ("Could not find compatible platform. Was: " <> what) + where getFreeBSDVersion = pure Nothing + +getLinuxDistro :: IO (LinuxDistro, Maybe Versioning) +getLinuxDistro = do + (name, ver) <- asum + [ try_os_release + , try_lsb_release_cmd + , try_lsb_release + , try_redhat_release + , try_debian_version + ] + let parsedVer = ver >>= either (const Nothing) Just . versioning + distro = if + | hasWord name (T.pack <$> ["debian"]) -> Debian + | hasWord name (T.pack <$> ["ubuntu"]) -> Ubuntu + | hasWord name (T.pack <$> ["linuxmint", "Linux Mint"]) -> Mint + | hasWord name (T.pack <$> ["fedora"]) -> Fedora + | hasWord name (T.pack <$> ["centos"]) -> CentOS + | hasWord name (T.pack <$> ["Red Hat"]) -> RedHat + | hasWord name (T.pack <$> ["alpine"]) -> Alpine + | hasWord name (T.pack <$> ["exherbo"]) -> Exherbo + | hasWord name (T.pack <$> ["gentoo"]) -> Gentoo + | otherwise -> UnknownLinux + pure (distro, parsedVer) where - getLinuxDistro :: IO LinuxDistro - getLinuxDistro = do - let os_release = [abs|/etc/os-release|] - lsb_release = [abs|/etc/lsb-release|] - redhat_release = [abs|/etc/redhat-release|] - debian_version = [abs|/etc/debian_version|] + hasWord t matches = foldr + (\x y -> + ( isJust + . ICU.find (ICU.regex [ICU.CaseInsensitive] (fS "\\b" <> x <> fS "\\b")) + $ t + ) + || y + ) + False + matches - pure undefined + os_release :: Path Abs + os_release = [abs|/etc/os-release|] + lsb_release :: Path Abs + lsb_release = [abs|/etc/lsb-release|] + lsb_release_cmd :: Path Fn + lsb_release_cmd = [fn|lsb-release|] + redhat_release :: Path Abs + redhat_release = [abs|/etc/redhat-release|] + debian_version :: Path Abs + debian_version = [abs|/etc/debian_version|] - getFreeBSDVersion = pure Nothing + try_os_release :: IO (Text, Maybe Text) + try_os_release = do + (Just name) <- getAssignmentValueFor os_release "NAME" + ver <- getAssignmentValueFor os_release "VERSION_ID" + pure (T.pack name, fmap T.pack ver) - -- Try various methods for getting distro name and version. - -- Failure is signalled with an IO exception. -try_os_release :: IO (String, P.Maybe String) -try_os_release = do - name <- getAssignmentValueFor [abs|/etc/os-release|] "NAME" >>= \case - P.Just s -> pure $ s - P.Nothing -> fail "No value found" - version <- getAssignmentValueFor [abs|/etc/os-release|] "VERSION_ID" - pure (name, version) + try_lsb_release_cmd :: IO (Text, Maybe Text) + try_lsb_release_cmd = do + (Just _ ) <- findExecutable lsb_release_cmd + (Just (name, _)) <- executeOut lsb_release_cmd [fS "-si"] + ver <- executeOut lsb_release_cmd [fS "-sr"] + pure (lBS2sT name, fmap (lBS2sT . fst) ver) + + try_lsb_release :: IO (Text, Maybe Text) + try_lsb_release = do + (Just name) <- getAssignmentValueFor lsb_release "DISTRIB_ID" + ver <- getAssignmentValueFor lsb_release "DISTRIB_RELEASE" + pure (T.pack name, fmap T.pack ver) + + try_redhat_release :: IO (Text, Maybe Text) + try_redhat_release = do + t <- fmap lBS2sT $ readFile redhat_release + let nameRe n = + join + . fmap (ICU.group 0) + . ICU.find + (ICU.regex [ICU.CaseInsensitive] (fS "\\b" <> fS n <> fS "\\b") + ) + $ t + verRe = + join + . fmap (ICU.group 0) + . ICU.find + (ICU.regex [ICU.CaseInsensitive] (fS "\\b(\\d)+(.(\\d)+)*\\b")) + $ t + (Just name) <- pure + (nameRe "CentOS" <|> nameRe "Fedora" <|> nameRe "Red Hat") + pure (name, verRe) + + try_debian_version :: IO (Text, Maybe Text) + try_debian_version = do + True <- doesFileExist debian_version + ver <- readFile debian_version + pure (T.pack "debian", Just $ lBS2sT ver) -try_lsb_release_cmd :: IO (String, P.Maybe String) -try_lsb_release_cmd = findExecutable ([fn|lsb_release|] :: Path Fn) >>= \case - P.Nothing -> fail "lsb_release not found" - P.Just path -> do - name <- executeOut ([fn|lsb_release|] :: Path Fn) [fS "-si"] >>= \case - P.Just (out, _) -> pure out - _ -> fail "Barfed output of lsb_release" - version <- (fmap . fmap) (UTF8.toString . fst) - $ executeOut ([fn|lsb_release|] :: Path Fn) [fS "-si"] - pure (UTF8.toString name, version) diff --git a/lib/GHCup/Bash.hs b/lib/GHCup/Bash.hs index a3bf8e2..17e8265 100644 --- a/lib/GHCup/Bash.hs +++ b/lib/GHCup/Bash.hs @@ -1,58 +1,47 @@ -module GHCup.Bash where +module GHCup.Bash + ( findAssignment + , equalsAssignmentWith + , getRValue + , getAssignmentValueFor + ) +where -import Data.ByteString -import Language.Bash.Parse.Word +import Language.Bash.Parse import Language.Bash.Word import Language.Bash.Syntax -import Text.Parsec import HPath +import HPath.IO import Data.ByteString.UTF8 ( toString ) -import Streamly -import GHCup.File -import GHCup.Prelude ( internalError ) -import qualified Streamly.Prelude as S -import Control.Monad -import Data.Maybe +import Control.Monad +import Data.Maybe +import qualified Data.ByteString.Lazy.UTF8 as UTF8 +import Prelude hiding ( readFile ) +import Data.List --- | Parse a single assignment of the given line. -parseAssignment :: SourceName -- ^ file/location of the parser - -> ByteString -- ^ the line as a bytestring - -> Either ParseError Assign -parseAssignment = runParser assign () +extractAssignments :: List -> [Assign] +extractAssignments (List stms) = join $ fmap getAssign $ getCommands stms + where + getCommands :: [Statement] -> [Command] + getCommands = join . fmap commands . catMaybes . fmap findPipes + where + findPipes (Statement (Last p@(Pipeline{})) Sequential) = Just p + findPipes _ = Nothing - --- | Parse assignments in a stream. -parseAssignments :: Monad m - => SourceName -- ^ file/location of the parser - -> SerialT m (ByteString) - -> SerialT m (Either ParseError Assign) -parseAssignments sn = fmap (parseAssignment sn) + getAssign :: Command -> [Assign] + getAssign (Command (SimpleCommand ass _) _) = ass + getAssign _ = [] -- | Find an assignment matching the predicate in the given file. -findAssignment :: Path b - -> (Assign -> Bool) -- ^ predicate - -> IO (Maybe Assign) +findAssignment :: Path b -> (Assign -> Bool) -> IO (Maybe Assign) findAssignment p predicate = do - let fn' = toString . toFilePath $ p - stream <- fmap (parseAssignments fn') $ readFileLines p - res <- - S.find -- empties the stream on first match, but doesn't terminate it - (\case - Right ass -> predicate ass - Left _ -> False - ) - stream - >>= \case - Just (Right x) -> pure (Just x) - Just (Left _) -> - internalError "unexpected Left in findAssignment" - Nothing -> pure Nothing - -- Closes the file handle. Because if there was a match, then - -- the stream is not terminated. - when (isJust res) $ S.drain stream - pure res + fileContents <- readFile p + -- TODO: this should accept bytestring: + -- https://github.com/knrafto/language-bash/issues/37 + case parse (toString . toFilePath $ p) (UTF8.toString fileContents) of + Left e -> fail $ show e + Right l -> pure $ find predicate (extractAssignments $ l) -- | Check that the assignment is of the form Foo= ignoring the diff --git a/lib/GHCup/File.hs b/lib/GHCup/File.hs index 012f09a..7e9c07b 100644 --- a/lib/GHCup/File.hs +++ b/lib/GHCup/File.hs @@ -1,6 +1,6 @@ module GHCup.File where -import Data.ByteString hiding (putStrLn) +import Data.ByteString import qualified Data.ByteString.Lazy as L import Data.Char import Data.Maybe @@ -14,7 +14,9 @@ import Control.Monad import Control.Exception.Safe import Data.Functor import System.Posix.Files.ByteString -import System.Posix.IO.ByteString hiding (openFd) +import System.IO +import System.Posix.IO.ByteString + hiding ( openFd ) import qualified System.Posix.Process.ByteString as SPPB import System.Posix.Types @@ -24,19 +26,11 @@ import qualified Streamly.Internal.Memory.ArrayStream import qualified Streamly.FileSystem.Handle as FH import qualified Streamly.Internal.Data.Unfold as SU import qualified Streamly.Prelude as S -import System.IO import System.Exit import qualified Streamly.Data.Fold as FL import Data.ByteString.Builder import Foreign.C.Error import GHCup.Prelude -import Control.Monad.Trans.Maybe -import HPath.Internal -import System.Posix.FD - ( - openFd - ) - -- |Checks whether a file is executable. Follows symlinks. @@ -66,20 +60,12 @@ readFd fd = do -- terminates (either through exception or because it's drained). readFileLines :: Path b -> IO (SerialT IO ByteString) readFileLines p = do - stream <- readFileStream' p + stream <- readFileStream p pure . (>>= arrayToByteString) . AS.splitOn (fromIntegral $ ord '\n') . (>>= byteStringToArray) $ stream - where - readFileStream' :: Path b - -> IO (SerialT IO ByteString) - readFileStream' (MkPath fp) = do - fd <- openFd fp ReadOnly [] Nothing - handle' <- fdToHandle fd - let stream = (S.unfold (SU.finally (\x -> putStrLn "hClose" >> hClose x) FH.readChunks) handle') >>= arrayToByteString - pure stream -- | Find the given executable by searching all *absolute* PATH components. @@ -92,42 +78,32 @@ findExecutable ex = do sPaths <- fmap catMaybes . (fmap . fmap) parseAbs $ getSearchPath -- We don't want exceptions to mess up our result. If we can't -- figure out if a file exists, then treat it as a negative result. - asum $ fmap (handleIOError (\_ -> pure Nothing)) $ fmap + asum $ fmap (handleIO (\_ -> pure Nothing)) $ fmap -- asum for short-circuiting behavior (\s -> (isExecutable (s ex) >>= guard) $> (Just (s ex))) sPaths -findExecutablee :: RelC r => Path r -> IO (Maybe (Path Abs)) -findExecutablee ex = do - sPaths <- mapMaybe parseAbs <$> getSearchPath - runMaybeT $ asum (MaybeT . eExists <$> sPaths) - where - eExists sp = let path = sp ex in handleIOError (pure $ pure Nothing) $ Just path <$ doesFileExist path - - --- TODO: fd leak -- | Execute the given command and collect the stdout and the exit code. executeOut :: Path Fn -- ^ command as filename, e.g. 'ls' -> [ByteString] -- ^ arguments to the command -> IO (Maybe (L.ByteString, ExitCode)) -- ^ fst of the tuple is the stdout executeOut path args = withFnPath path $ \fp -> do - (readE, writeE) <- createPipe - pid <- SPPB.forkProcess $ do + (parentRead, childWrite) <- createPipe + pid <- SPPB.forkProcess $ do whileM_ - (dupTo writeE stdOutput) + (dupTo childWrite stdOutput) (\r -> getErrno >>= \e -> pure $ r == fromIntegral (-1 :: Int) && e == eINTR ) - closeFd writeE - closeFd readE + closeFd childWrite + closeFd parentRead + closeFd stdInput SPPB.executeFile fp True args Nothing - closeFd writeE + closeFd childWrite - -- readFd will take care of closing the fd SPPB.getProcessStatus True True pid >>= \case - Just (SPPB.Exited es) -> do - out <- readFd readE - pure $ Just (out, es) - _ -> pure Nothing + -- readE will take care of closing the fd + Just (SPPB.Exited es) -> readFd parentRead <&> Just . (, es) + _ -> closeFd parentRead $> Nothing diff --git a/lib/GHCup/Prelude.hs b/lib/GHCup/Prelude.hs index dce1002..35942de 100644 --- a/lib/GHCup/Prelude.hs +++ b/lib/GHCup/Prelude.hs @@ -5,16 +5,21 @@ module GHCup.Prelude where import Control.Applicative +import Control.Monad import Data.Strict.Maybe import Data.Monoid ( (<>) ) import Prelude ( Monad , Bool , return , (.) - , (>>=) ) import qualified Prelude as P -import Data.String +import Data.String +import qualified Data.Text.Lazy.Encoding as TLE +import qualified Data.Text.Lazy as TL +import Data.Text ( Text ) +import qualified Data.ByteString.Lazy as L + fS :: IsString a => P.String -> a @@ -23,9 +28,15 @@ fS = fromString fromStrictMaybe :: Maybe a -> P.Maybe a fromStrictMaybe = maybe P.Nothing P.Just +fSM :: Maybe a -> P.Maybe a +fSM = fromStrictMaybe + toStrictMaybe :: P.Maybe a -> Maybe a toStrictMaybe = P.maybe Nothing Just +tSM :: P.Maybe a -> Maybe a +tSM = toStrictMaybe + instance Applicative Maybe where pure = Just @@ -61,6 +72,17 @@ ifM ~b ~t ~f = do b' <- b if b' then t else f -whileM_ :: Monad m => m a -> (a -> m Bool) -> m () -whileM_ action f = whenM (action >>= f) (whileM_ action f) +whileM :: Monad m => m a -> (a -> m Bool) -> m a +whileM ~action ~f = do + a <- action + b' <- f a + if b' then whileM action f else pure a +whileM_ :: Monad m => m a -> (a -> m Bool) -> m () +whileM_ ~action = void . whileM action + +guardM :: (Monad m, Alternative m) => m Bool -> m () +guardM f = guard =<< f + +lBS2sT :: L.ByteString -> Text +lBS2sT = TL.toStrict . TLE.decodeUtf8 diff --git a/lib/GHCup/Types.hs b/lib/GHCup/Types.hs index 0b8c70b..3d67e3c 100644 --- a/lib/GHCup/Types.hs +++ b/lib/GHCup/Types.hs @@ -2,50 +2,66 @@ module GHCup.Types where -import Data.Map.Strict (Map) -import Data.Strict.Maybe -import Data.Text -import Data.Version -import Network.URL -import Prelude hiding ( - Maybe - , Just - , Nothing) - -import qualified GHC.Generics as GHC +import Data.Map.Strict ( Map ) +import Network.URL +import qualified GHC.Generics as GHC +import Data.Versions --- | Requested tool to be installed. User input. data Tool = GHC | Cabal | Stack deriving (Eq, Ord, Show) --- | Architecture we run on. +data ToolRequest = ToolRequest { + _tool :: Tool + , _toolVersion :: Version +} deriving (Eq, Show) + data Architecture = A_64 | A_32 deriving (Eq, Ord, Show) -data LinuxDistro = Debian (Maybe CustomVersion) - | Ubuntu (Maybe CustomVersion) - | Mint (Maybe CustomVersion) - | Fedora (Maybe CustomVersion) +data LinuxDistro = Debian + | Ubuntu + | Mint + | Fedora + | CentOS + | RedHat + | Alpine + -- rolling + | Gentoo + | Exherbo -- not known | UnknownLinux -- ^ must exit deriving (Eq, GHC.Generic, Ord, Show) - data Platform = Linux LinuxDistro -- ^ must exit | Darwin -- ^ must exit - | FreeBSD (Maybe CustomVersion) + | FreeBSD deriving (Eq, GHC.Generic, Ord, Show) -type CustomVersion = Text -type PlatformSpec = Map Platform URL -type ArchitectureSpec = Map Architecture PlatformSpec -type VersionSpec = Map Version ArchitectureSpec -type AvailableDownloads = Map Tool VersionSpec +data PlatformResult = PlatformResult { + _platform :: Platform + , _distroVersion :: Maybe Versioning +} deriving (Eq, Show) +data PlatformRequest = PlatformRequest { + _rArch :: Architecture + , _rPlatform :: Platform + , _rVersion :: Maybe Versioning +} deriving (Eq, Show) + +type PlatformVersionSpec = Map (Maybe Versioning) URL +type PlatformSpec = Map Platform PlatformVersionSpec +type ArchitectureSpec = Map Architecture PlatformSpec +type ToolVersionSpec = Map Version ArchitectureSpec +type AvailableDownloads = Map Tool ToolVersionSpec + + +data URLSource = GHCupURL + | OwnSource URL + | OwnSpec AvailableDownloads diff --git a/lib/GHCup/Types/Foo.hs b/lib/GHCup/Types/Foo.hs deleted file mode 100644 index 8802c5a..0000000 --- a/lib/GHCup/Types/Foo.hs +++ /dev/null @@ -1,18 +0,0 @@ -encToJsonNoSpaces - :: ( Monoid t - , Applicative f - ) - => AReview Json (b, t) - -> (a -> b) - -> Encoder f a -encToJsonNoSpaces c f = - encodeA (pure . review c . (, mempty) . f) - -bytestring :: Applicative f => Encoder f ByteString -bytestring = encToJsonNoSpaces _JStr (_JStringBS #) - -_JStringBS :: (Profunctor p, Applicative f) - => p ByteString (f ByteString) - -> p JString (f JString) -_JStringBS = iso (C.pack . review _JString) - (JString' . V.fromList . fmap utf8CharToJChar . C.unpack) diff --git a/lib/GHCup/Types/JSON.hs b/lib/GHCup/Types/JSON.hs index a410b86..b0249bc 100644 --- a/lib/GHCup/Types/JSON.hs +++ b/lib/GHCup/Types/JSON.hs @@ -9,32 +9,21 @@ module GHCup.Types.JSON where -import Data.Strict.Maybe -import GHCup.Types -import Generics.SOP.TH -import Prelude hiding ( - Maybe - , Just - , Nothing) -import Waargonaut.Generic ( - JsonEncode - , JsonDecode - , GWaarg) +import Data.Strict.Maybe +import GHCup.Types +import Prelude hiding ( Maybe ) +import Data.Versions +import Data.Aeson +import Data.Aeson.TH -deriveGeneric ''Maybe -instance JsonEncode GWaarg a => JsonEncode GWaarg (Maybe a) -instance JsonDecode GWaarg a => JsonDecode GWaarg (Maybe a) - -deriveGeneric ''Tool -instance JsonEncode GWaarg Tool -instance JsonDecode GWaarg Tool - -deriveGeneric ''Architecture -instance JsonEncode GWaarg Architecture -instance JsonDecode GWaarg Architecture - -deriveGeneric ''LinuxDistro -instance JsonEncode GWaarg LinuxDistro -instance JsonDecode GWaarg LinuxDistro - +deriveJSON defaultOptions ''Architecture +deriveJSON defaultOptions ''LinuxDistro +deriveJSON defaultOptions ''Maybe +deriveJSON defaultOptions ''Mess +deriveJSON defaultOptions ''SemVer +deriveJSON defaultOptions ''Tool +deriveJSON defaultOptions ''VSep +deriveJSON defaultOptions ''VUnit +deriveJSON defaultOptions ''Version +deriveJSON defaultOptions ''Versioning diff --git a/lib/GHCup/Types/Optics.hs b/lib/GHCup/Types/Optics.hs index d392cfa..061fc4d 100644 --- a/lib/GHCup/Types/Optics.hs +++ b/lib/GHCup/Types/Optics.hs @@ -2,4 +2,15 @@ module GHCup.Types.Optics where +import GHCup.Types +import Optics + +makePrisms ''Tool +makePrisms ''Architecture +makePrisms ''LinuxDistro +makePrisms ''Platform + +makeLenses ''PlatformResult +makeLenses ''ToolRequest +