summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorJensPetersen <>2019-04-15 06:49:00 (GMT)
committerhdiff <hdiff@hdiff.luite.com>2019-04-15 06:49:00 (GMT)
commitb5ba3b7426130c680531b24d0a3d6f437e77a1fd (patch)
tree440489f2847397ac9bf267b7f7d568fdb93159bc
parent1ab5967106bbb949341109fed44bae230f89b100 (diff)
version 0.20.2
-rw-r--r--CHANGELOG.md4
-rw-r--r--Main.hs177
-rw-r--r--README.md18
-rw-r--r--fedora-img-dl.cabal13
4 files changed, 127 insertions, 85 deletions
diff --git a/CHANGELOG.md b/CHANGELOG.md
index 97dfd92..57c902b 100644
--- a/CHANGELOG.md
+++ b/CHANGELOG.md
@@ -1,4 +1,8 @@
# Changelog
+## 0.2
+- fix and improve symlink naming
+- use new http-directory library to check exact filesize
+
## 0.1
* initial release
diff --git a/Main.hs b/Main.hs
index 5753985..912d5dc 100644
--- a/Main.hs
+++ b/Main.hs
@@ -7,61 +7,81 @@ import Control.Applicative ((<$>), (<*>))
import Control.Monad (when, unless)
import qualified Data.ByteString.Char8 as B
+import Data.Char (isDigit, toLower)
+import Data.List (intercalate)
import Data.Maybe
import Data.Semigroup ((<>))
import Data.Text (Text)
+import qualified Data.Text as T
-import Network.HTTP.Client (brConsume, hrFinalResponse, hrRedirects, newManager, parseRequest, responseBody, responseHeaders, responseOpenHistory, responseStatus)
+import Network.HTTP.Client (newManager)
import Network.HTTP.Client.TLS (tlsManagerSettings)
-import Network.HTTP.Types (decodePathSegments, extractPath, statusCode)
+import Network.HTTP.Types (decodePathSegments, extractPath)
-import qualified Data.Text as T
+import Network.HTTP.Directory
import Options.Applicative (auto, fullDesc, header, optional, progDescDoc)
import qualified Options.Applicative.Help.Pretty as P
-import Text.HTML.DOM (parseBSChunks)
-import Text.XML.Cursor
+
+import Paths_fedora_img_dl (version)
import SimpleCmd (cmd_, error')
import SimpleCmdArgs
-import Paths_fedora_img_dl (version)
-import System.Directory (doesFileExist, getPermissions, removeFile,
+import System.Directory (createDirectoryIfMissing, doesDirectoryExist,
+ doesFileExist, getPermissions, removeFile,
setCurrentDirectory, writable)
import System.Environment.XDG.UserDir (getUserDir)
-import System.FilePath (takeExtension, takeFileName, (</>), (<.>))
-import System.Posix.Files (createSymbolicLink, readSymbolicLink)
+import System.FilePath (joinPath, takeExtension, takeFileName, (</>), (<.>))
+import System.Posix.Files (createSymbolicLink, fileSize, getFileStatus,
+ readSymbolicLink)
+
+import Text.Read
+import qualified Text.ParserCombinators.ReadP as R
+import qualified Text.ParserCombinators.ReadPrec as RP
data FedoraEdition = Cloud
| Container
| Everything
| Server
| Silverblue
- | Spins
| Workstation
- deriving (Read, Show)
+ deriving (Show, Enum, Bounded)
+
+instance Read FedoraEdition where
+ readPrec = do
+ s <- look
+ let e = map toLower s
+ editionMap =
+ map (\ ed -> (map toLower (show ed), ed)) [minBound..maxBound]
+ res = lookup e editionMap
+ case res of
+ Nothing -> error' "unknown edition" >> RP.pfail
+ Just ed -> RP.lift (R.string e) >> return ed
main :: IO ()
main =
let pdoc = Just $ P.text "Tool for downloading Fedora iso file images."
- P.<$$> P.text "RELEASE can be 'rawhide', 'branched', 'respin', 'beta' or release version" in
+ P.<$$> P.text "RELEASE can be 'rawhide', 'respin', 'beta' or release version" in
simpleCmdArgsWithMods (Just version) (fullDesc <> header "Fedora iso downloader" <> progDescDoc pdoc) $
findISO
- <$> switchWith 'n' "dry-run" "Don't actually download anything"
- <*> optional (strOptionWith 'm' "mirror" "HOST" "default https://download.fedoraproject.org")
+ <$> optional (strOptionWith 'm' "mirror" "HOST" "default https://download.fedoraproject.org")
+ <*> switchWith 'n' "dry-run" "Don't actually download anything"
<*> strOptionalWith 'a' "arch" "ARCH" "architecture (default x86_64)" "x86_64"
- <*> optionalWith auto 'e' "edition" "EDITION" "Fedora edition (Workstation [default], Server, ...)" Workstation
+ <*> optionalWith auto 'e' "edition" "EDITION" "Fedora edition: workstation [default], server, ..." Workstation
<*> strArg "RELEASE"
-findISO :: Bool -> Maybe String -> String -> FedoraEdition -> String -> IO ()
-findISO dryrun mhost arch edition release = do
- let (mlocn, relpath, mprefix) =
- case release of
- "rawhide" -> (Nothing, "development/rawhide", Nothing)
- "respin" -> (Just "https://dl.fedoraproject.org", "pub/alt/live-respins/", Just "F29-WORK-x86_64")
- "beta" -> (Nothing ,"releases/test/30_Beta", Nothing) -- FIXME: navigate!
- rel | rel `elem` ["30", "branched"] -> (Nothing, "development/30", Nothing) -- FIXME: navigate!
- _ -> (Nothing, "releases" </> release, Nothing)
+findISO :: Maybe String -> Bool -> String -> FedoraEdition -> String -> IO ()
+findISO mhost dryrun arch edition tgtrel = do
+ let (mlocn, relpath, mprefix, mrelease) =
+ case tgtrel of
+ "rawhide" -> (Nothing, "development/rawhide", Nothing, Just "Rawhide")
+ -- FIXME: version hardcoding for respin, beta, and 30
+ "respin" -> (Just "https://dl.fedoraproject.org", "pub/alt/live-respins/", Just "F29-WORK-x86_64", Nothing)
+ "beta" -> (Nothing ,"releases/test/30_Beta", Nothing, Just "30_Beta") -- FIXME: hardcoding
+ "30" -> (Nothing, "development/30", Nothing, Just "30") -- FIXME: hardcoding
+ rel | all isDigit rel -> (Nothing, "releases" </> rel, Nothing, Just rel)
+ _ -> error' "Unknown release"
when (isJust mlocn && isJust mhost && mlocn /= mhost) $
error' "Cannot specify host for this image"
let host = fromMaybe "https://download.fedoraproject.org" $
@@ -69,62 +89,71 @@ findISO dryrun mhost arch edition release = do
toppath = if null ((decodePathSegments . extractPath) (B.pack host))
then "pub/fedora/linux"
else ""
- url = if isJust mlocn then host </> relpath else host </> toppath </> relpath </> show edition </> arch </> editionMedia edition ++ "/"
- fileurl <- checkURL url mprefix
- putStrLn fileurl
- unless dryrun $ do
- dlDir <- getUserDir "DOWNLOAD"
+ url = if isJust mlocn then host </> relpath else joinPath [host, toppath, relpath, show edition, arch, editionMedia edition <> "/"]
+ prefix = fromMaybe (intercalate "-" ([editionPrefix edition, arch] <> maybeToList mrelease)) mprefix
+ (fileurl, remotesize) <- findURL url prefix
+ dlDir <- getUserDir "DOWNLOAD"
+ if dryrun
+ then do
+ dirExists <- doesDirectoryExist dlDir
+ when dirExists $ setCurrentDirectory dlDir
+ else do
+ createDirectoryIfMissing False dlDir
setCurrentDirectory dlDir
- let localfile = takeFileName fileurl
- exists <- doesFileExist localfile
- when exists $ do
- putStrLn "Image file already exists"
+ let localfile = takeFileName fileurl
+ symlink = dlDir </> prefix <> "-latest" <.> takeExtension fileurl
+ exists <- doesFileExist localfile
+ if exists
+ then do
+ filestatus <- getFileStatus localfile
+ let localsize = fileSize filestatus
+ if Just (fromIntegral localsize) == remotesize
+ then do
+ putStrLn "File already fully downloaded"
+ updateSymlink localfile symlink
+ else do
canwrite <- writable <$> getPermissions localfile
unless canwrite $ error' "file does have write permission, aborting!"
- cmd_ "curl" ["-C", "-", "-O", fileurl]
- let symlink = dlDir </> T.unpack (editionPrefix edition) ++ "-" ++ arch ++ "-" ++ show release ++ "-latest" <.> takeExtension fileurl
- symExists <- doesFileExist symlink
- if symExists
- then do
- lnktgt <- readSymbolicLink symlink
- unless (lnktgt == localfile) $ do
- removeFile symlink
- createSymlink localfile symlink
- else createSymlink localfile symlink
+ downloadFile fileurl
+ updateSymlink localfile symlink
+ else do
+ downloadFile fileurl
+ updateSymlink localfile symlink
where
- checkURL :: String -> Maybe Text -> IO String
- checkURL url mprefix = do
- req <- parseRequest url
+ findURL :: String -> String -> IO (String, Maybe Integer)
+ findURL url prefix = do
mgr <- newManager tlsManagerSettings
- respHist <- responseOpenHistory req mgr
- let redirect = listToMaybe . reverse $ mapMaybe (lookup "Location" . responseHeaders . snd) $ hrRedirects respHist
+ redirect <- httpRedirect mgr url
let finalUrl = maybe url B.unpack redirect
- when (isJust redirect) $ putStr "Redirected to "
- let response = hrFinalResponse respHist
- -- print finalUrl
- if statusCode (responseStatus response) /= 200
- then
- error' $ show $ responseStatus response
- else do
- body <- brConsume $ responseBody response
- let doc = parseBSChunks body
- cursor = fromDocument doc
- hrefs = concatMap (attribute "href") $ cursor $// element "a"
- prefix = fromMaybe (editionPrefix edition) mprefix
- mfile = listToMaybe $ filter (prefix `T.isPrefixOf`) hrefs :: Maybe Text
- case mfile of
- Nothing -> do
- print doc
- error' $ "not found " ++ finalUrl
- Just file ->
- return $ finalUrl </> T.unpack file
-
- createSymlink :: FilePath -> FilePath -> IO ()
- createSymlink tgt symlink = do
- createSymbolicLink tgt symlink
- putStrLn $ symlink ++ " -> " ++ tgt
-
-editionPrefix :: FedoraEdition -> Text
+ hrefs <- httpDirectory mgr finalUrl
+ let mfile = listToMaybe $ filter (T.pack prefix `T.isPrefixOf`) hrefs :: Maybe Text
+ case mfile of
+ Nothing ->
+ error' $ "not found " <> finalUrl
+ Just file -> do
+ let finalfile = finalUrl </> T.unpack file
+ putStrLn finalfile
+ size <- httpFileSize mgr finalfile
+ return (finalfile, size)
+
+ updateSymlink :: FilePath -> FilePath -> IO ()
+ updateSymlink target symlink =
+ unless dryrun $ do
+ symExists <- doesFileExist symlink
+ if symExists
+ then do
+ linktarget <- readSymbolicLink symlink
+ when (linktarget /= target) $ do
+ removeFile symlink
+ createSymbolicLink target symlink
+ else createSymbolicLink target symlink
+ putStrLn $ unwords [symlink, "->", target]
+
+ downloadFile :: String -> IO ()
+ downloadFile url =
+ unless dryrun $ cmd_ "curl" ["-C", "-", "-O", url]
+
+editionPrefix :: FedoraEdition -> String
editionPrefix Workstation = "Fedora-Workstation-Live"
editionPrefix Server = "Fedora-Server-dvd"
editionPrefix Silverblue = "Fedora-Silverblue-ostree"
diff --git a/README.md b/README.md
index c15359a..63e7e24 100644
--- a/README.md
+++ b/README.md
@@ -5,10 +5,20 @@
[![Stackage Lts](http://stackage.org/package/fedora-img-dl/badge/lts)](http://stackage.org/lts/package/fedora-img-dl)
[![Stackage Nightly](http://stackage.org/package/fedora-img-dl/badge/nightly)](http://stackage.org/nightly/package/fedora-img-dl)
-Fedora image download tool
+A tool for downloading Fedora images.
+By default it targets the Workstation edition of Fedora.
-`fedora-img-dl 31` downloads by default the Fedora 31 Workstation Live iso
+Usage example:
-`fedora-img-dl -e Silverblue` downloads Fedora 30 Silverblue iso
+`fedora-img-dl rawhide` : downloads the latest Fedora Rawhide Workstation Live iso
-`fedora-img-dl --edition Silver --arch aarch64 29` will bring down F29 Server iso
+`fedora-img-dl respin` : downloads the latest Live Workstation respin
+
+`fedora-img-dl -e silverblue 30` : downloads Fedora 30 Silverblue iso
+
+`fedora-img-dl --edition server --arch aarch64 29` : will bring down the F29 Server iso
+
+(Currently Spins are not yet supported.)
+
+A symlink to the latest iso is also created:
+eg for rawhide it might be `Fedora-Workstation-Live-x86_64-Rawhide-latest.iso`.
diff --git a/fedora-img-dl.cabal b/fedora-img-dl.cabal
index b1ff1fd..dca30cd 100644
--- a/fedora-img-dl.cabal
+++ b/fedora-img-dl.cabal
@@ -1,10 +1,13 @@
cabal-version: 1.18
name: fedora-img-dl
-version: 0.1
+version: 0.2
synopsis: Fedora image download tool
description: Tool to download Fedora iso and image files
+-- can change to GPL-3.0-or-later with Cabal-2
license: GPL-3
license-file: LICENSE
+homepage: https://github.com/juhp/fedora-img-dl
+bug-reports: https://github.com/juhp/fedora-img-dl/issues
author: Jens Petersen
maintainer: juhpetersen@gmail.com
copyright: 2019 Jens Petersen
@@ -27,19 +30,16 @@ executable fedora-img-dl
bytestring,
directory,
filepath,
- html-conduit,
http-client,
http-client-tls,
+ http-directory,
http-types,
- hxt,
- network-uri,
optparse-applicative,
simple-cmd >= 0.1.4,
simple-cmd-args >= 0.1.1,
text,
unix,
- xdg-userdirs,
- xml-conduit
+ xdg-userdirs
if impl(ghc<8.0)
Build-depends: semigroups
@@ -47,4 +47,3 @@ executable fedora-img-dl
-Wall
default-language: Haskell2010
- default-extensions: OverloadedStrings