Yo

lib/GHCup/Download.hs

@@ -23,6 +23,7 @@ import           GHCup.Utils.String.QQ
 import           Control.Applicative
 import           Control.Exception.Safe
 import           Control.Monad
+import           Control.Monad.Fail             ( MonadFail )
 import           Control.Monad.Logger
 import           Control.Monad.Reader
 import           Control.Monad.Trans.Class      ( lift )
@@ -31,10 +32,14 @@ import           Control.Monad.Trans.Resource
 import           Data.Aeson
 import           Data.ByteString                ( ByteString )
 import           Data.ByteString.Builder
+import           Data.CaseInsensitive           ( CI )
 import           Data.IORef
 import           Data.Maybe
 import           Data.String.Interpolate
 import           Data.Text.Read
+import           Data.Time.Clock
+import           Data.Time.Clock.POSIX
+import           Data.Time.Format
 import           Data.Versions
 import           GHC.IO.Exception
 import           HPath
@@ -61,6 +66,9 @@ import           URI.ByteString.QQ
 import qualified Data.Binary.Builder           as B
 import qualified Data.ByteString               as BS
 import qualified Data.ByteString.Lazy          as L
+import qualified Data.CaseInsensitive          as CI
+import qualified Data.Map.Strict               as M
+import qualified Data.Text                     as T
 import qualified Data.Text.Encoding            as E
 import qualified System.IO.Streams             as Streams
 import qualified System.Posix.RawFilePath.Directory
@@ -69,8 +77,7 @@ import qualified System.Posix.RawFilePath.Directory
 
 
 ghcupURL :: URI
-ghcupURL =
-  [uri|https://gist.githubusercontent.com/hasufell/5411271eb4ae52e16ad2200f80eb2813/raw/eb47b3c9d85edf3a4df2b869f8a8eda87fa94bb4/gistfile1.txt|]
+ghcupURL = [uri|https://www.haskell.org/ghcup/data/ghcup-0.0.1.json|]
 
 
 
@@ -79,7 +86,7 @@ ghcupURL =
     ------------------
 
 
--- | Downloads the download information!
+-- | Downloads the download information! But only if we need to ;P
 getDownloads :: ( FromJSONKey Tool
                 , FromJSONKey Version
                 , FromJSON VersionInfo
@@ -87,6 +94,8 @@ getDownloads :: ( FromJSONKey Tool
                 , MonadCatch m
                 , MonadReader Settings m
                 , MonadLogger m
+                , MonadThrow m
+                , MonadFail m
                 )
              => Excepts '[JSONError , DownloadFailed] m GHCupDownloads
 getDownloads = do
@@ -94,13 +103,85 @@ getDownloads = do
   lift $ $(logDebug) [i|Receiving download info from: #{urlSource}|]
   case urlSource of
     GHCupURL -> do
-      bs <- reThrowAll DownloadFailed $ downloadBS ghcupURL
+      bs <- reThrowAll DownloadFailed $ dl ghcupURL
       lE' JSONDecodeError $ eitherDecode' bs
     (OwnSource url) -> do
-      bs <- reThrowAll DownloadFailed $ downloadBS url
+      bs <- reThrowAll DownloadFailed $ dl url
       lE' JSONDecodeError $ eitherDecode' bs
     (OwnSpec av) -> pure $ av
 
+ where
+  -- First send a HEAD request and check for modification time.
+  -- Only download the file if the modification time is newer
+  -- than the local file. Always save the local file with the
+  -- mod time of the remote file.
+  dl :: forall m1
+      . (MonadCatch m1, MonadIO m1, MonadFail m1, MonadLogger m1)
+     => URI
+     -> Excepts
+          '[ FileDoesNotExistError
+           , HTTPStatusError
+           , URIParseError
+           , UnsupportedScheme
+           , NoLocationHeader
+           , TooManyRedirs
+           ]
+          m1
+          L.ByteString
+  dl uri' = do
+    let path = view pathL' uri'
+    json_file <- (liftIO $ ghcupCacheDir)
+      >>= \cacheDir -> (cacheDir </>) <$> urlBaseName path
+    headers <-
+      handleIO (\_ -> pure mempty)
+      $ liftE
+      $ ( catchAllE
+            (\_ ->
+              pure mempty :: Excepts '[] m1 (M.Map (CI ByteString) ByteString)
+            )
+        $ getHead uri'
+        )
+    let mModT = parseModifiedHeader headers
+    e <- liftIO $ doesFileExist json_file
+    if e
+      then do
+        case mModT of
+          Just modTime -> do
+            fileMod <- liftIO $ getModificationTime json_file
+            if modTime > fileMod
+              then do
+                bs <- liftE $ downloadBS uri'
+                liftIO $ writeFileWithModTime modTime json_file bs
+                pure bs
+              else liftIO $ readFile json_file
+          Nothing -> do
+            lift $ $(logWarn) [i|Unable to get/parse Last-Modified header|]
+            liftIO $ deleteFile json_file
+            liftE $ downloadBS uri'
+      else do
+        case mModT of
+          Just modTime -> do
+            bs <- liftE $ downloadBS uri'
+            liftIO $ writeFileWithModTime modTime json_file bs
+            pure bs
+          Nothing -> do
+            lift $ $(logWarn) [i|Unable to get/parse Last-Modified header|]
+            liftE $ downloadBS uri'
+
+  parseModifiedHeader :: (M.Map (CI ByteString) ByteString) -> Maybe UTCTime
+  parseModifiedHeader headers =
+    (M.lookup (CI.mk [s|Last-Modified|]) headers) >>= \h -> parseTimeM
+      True
+      defaultTimeLocale
+      "%a, %d %b %Y %H:%M:%S %Z"
+      (T.unpack . E.decodeUtf8 $ h)
+
+  writeFileWithModTime :: UTCTime -> Path Abs -> L.ByteString -> IO ()
+  writeFileWithModTime utctime path content = do
+    let mod_time = utcTimeToPOSIXSeconds utctime
+    writeFileL path (Just newFilePerms) content
+    setModificationTimeHiRes path mod_time
+
 
 
 getDownloadInfo :: ( MonadLogger m
@@ -206,7 +287,6 @@ download dli dest mfn
       $ reThrowAll DownloadFailed
       $ downloadInternal True https host fullPath port stepper
 
-    -- TODO: verify md5 during download
     liftE $ checkDigest dli destFile
     pure destFile
 
@@ -282,13 +362,8 @@ downloadBS uri'
   scheme = view (uriSchemeL' % schemeBSL') uri'
   path   = view pathL' uri'
   dl https = do
-    host <-
-      preview (authorityL' % _Just % authorityHostL' % hostBSL') uri'
-        ?? UnsupportedScheme
-    let port = preview
-          (authorityL' % _Just % authorityPortL' % _Just % portNumberL')
-          uri'
-    liftE $ downloadBS' https host path port
+    (_, host', fullPath', port') <- liftE $ uriToQuadruple uri'
+    liftE $ downloadBS' https host' fullPath' port'
 
 
 -- | Load the result of this download into memory at once.
@@ -333,20 +408,12 @@ downloadInternal = go (5 :: Int)
 
  where
   go redirs progressBar https host path port consumer = do
-    r <- liftIO $ bracket acquire release' action
+    r <- liftIO $ withConnection' https host port action
     veitherToExcepts r >>= \case
       Just r' ->
         if redirs > 0 then followRedirectURL r' else throwE TooManyRedirs
       Nothing -> pure ()
    where
-    acquire = case https of
-      True -> do
-        ctx <- baselineContextSSL
-        openConnectionSSL ctx host (fromIntegral $ fromMaybe 443 port)
-      False -> openConnection host (fromIntegral $ fromMaybe 80 port)
-
-    release' = closeConnection
-
     action c = do
       let q = buildRequest1 $ http GET path
 
@@ -392,6 +459,95 @@ downloadInternal = go (5 :: Int)
 
 
 
+getHead :: (MonadCatch m, MonadIO m)
+        => URI
+        -> Excepts
+             '[ HTTPStatusError
+              , URIParseError
+              , UnsupportedScheme
+              , NoLocationHeader
+              , TooManyRedirs
+              ]
+             m
+             (M.Map (CI ByteString) ByteString)
+getHead uri' | scheme == [s|https|] = head' True
+             | scheme == [s|http|] = head' False
+             | otherwise           = throwE UnsupportedScheme
+
+ where
+  scheme = view (uriSchemeL' % schemeBSL') uri'
+  head' https = do
+    (_, host', fullPath', port') <- liftE $ uriToQuadruple uri'
+    liftE $ headInternal https host' fullPath' port'
+
+
+
+headInternal :: MonadIO m
+             => Bool        -- ^ https?
+             -> ByteString  -- ^ host
+             -> ByteString  -- ^ path with query
+             -> Maybe Int   -- ^ optional port
+             -> Excepts
+                  '[ HTTPStatusError
+                   , URIParseError
+                   , UnsupportedScheme
+                   , TooManyRedirs
+                   , NoLocationHeader
+                   ]
+                  m
+                  (M.Map (CI ByteString) ByteString)
+headInternal = go (5 :: Int)
+
+ where
+  go redirs https host path port = do
+    r <- liftIO $ withConnection' https host port action
+    veitherToExcepts r >>= \case
+      Left r' ->
+        if redirs > 0 then followRedirectURL r' else throwE TooManyRedirs
+      Right hs -> pure hs
+   where
+
+    action c = do
+      let q = buildRequest1 $ http HEAD path
+
+      sendRequest c q emptyBody
+
+      unsafeReceiveResponse
+        c
+        (\r _ -> runE $ do
+          let scode = getStatusCode r
+          if
+            | scode >= 200 && scode < 300 -> do
+              let headers = getHeaderMap r
+              pure $ Right $ headers
+            | scode >= 300 && scode < 400 -> case getHeader r [s|Location|] of
+              Just r' -> pure $ Left $ r'
+              Nothing -> throwE NoLocationHeader
+            | otherwise -> throwE $ HTTPStatusError scode
+        )
+
+    followRedirectURL bs = case parseURI strictURIParserOptions bs of
+      Right uri' -> do
+        (https', host', fullPath', port') <- liftE $ uriToQuadruple uri'
+        go (redirs - 1) https' host' fullPath' port'
+      Left e -> throwE e
+
+
+withConnection' :: Bool
+                -> ByteString
+                -> Maybe Int
+                -> (Connection -> IO a)
+                -> IO a
+withConnection' https host port action = bracket acquire closeConnection action
+
+ where
+  acquire = case https of
+    True -> do
+      ctx <- baselineContextSSL
+      openConnectionSSL ctx host (fromIntegral $ fromMaybe 443 port)
+    False -> openConnection host (fromIntegral $ fromMaybe 80 port)
+
+
 -- | Extracts from a URI type: (https?, host, path+query, port)
 uriToQuadruple :: Monad m
                => URI

lib/GHCup/Types.hs

@@ -12,6 +12,97 @@ import qualified GHC.Generics                  as GHC
 
 
 
+
+    ---------------------
+    --[ Download Tree ]--
+    ---------------------
+
+
+-- | Description of all binary and source downloads. This is a tree
+-- of nested maps.
+type GHCupDownloads = Map Tool ToolVersionSpec
+type ToolVersionSpec = Map Version VersionInfo
+type ArchitectureSpec = Map Architecture PlatformSpec
+type PlatformSpec = Map Platform PlatformVersionSpec
+type PlatformVersionSpec = Map (Maybe Versioning) DownloadInfo
+
+
+-- | An installable tool.
+data Tool = GHC
+          | Cabal
+          | GHCup
+  deriving (Eq, GHC.Generic, Ord, Show)
+
+
+-- | All necessary information of a tool version, including
+-- source download and per-architecture downloads.
+data VersionInfo = VersionInfo
+  { _viTags     :: [Tag]              -- ^ version specific tag
+  , _viSourceDL :: Maybe DownloadInfo -- ^ source tarball
+  , _viArch     :: ArchitectureSpec   -- ^ descend for binary downloads per arch
+  }
+  deriving (Eq, Show)
+
+
+-- | A tag. These are currently attached to a version of a tool.
+data Tag = Latest
+         | Recommended
+         deriving (Ord, Eq, Show)
+
+
+data Architecture = A_64
+                  | A_32
+  deriving (Eq, GHC.Generic, Ord, Show)
+
+
+data Platform = Linux LinuxDistro
+              -- ^ must exit
+              | Darwin
+              -- ^ must exit
+              | FreeBSD
+  deriving (Eq, GHC.Generic, Ord, Show)
+
+data LinuxDistro = Debian
+                 | Ubuntu
+                 | Mint
+                 | Fedora
+                 | CentOS
+                 | RedHat
+                 | Alpine
+                 | AmazonLinux
+                 -- rolling
+                 | Gentoo
+                 | Exherbo
+                 -- not known
+                 | UnknownLinux
+                 -- ^ must exit
+  deriving (Eq, GHC.Generic, Ord, Show)
+
+
+-- | An encapsulation of a download. This can be used
+-- to download, extract and install a tool.
+data DownloadInfo = DownloadInfo
+  { _dlUri    :: URI
+  , _dlSubdir :: Maybe (Path Rel)
+  , _dlHash   :: Text
+  }
+  deriving (Eq, Show)
+
+
+
+
+    --------------
+    --[ Others ]--
+    --------------
+
+
+-- | Where to fetch GHCupDownloads from.
+data URLSource = GHCupURL
+               | OwnSource URI
+               | OwnSpec GHCupDownloads
+               deriving Show
+
+
 data Settings = Settings
   { cache     :: Bool
   , urlSource :: URLSource
@@ -33,61 +124,11 @@ data DebugInfo = DebugInfo
 
 
 data SetGHC = SetGHCOnly  -- ^ unversioned 'ghc'
-            | SetGHCMajor -- ^ ghc-x.y
-            | SetGHCMinor -- ^ ghc-x.y.z -- TODO: rename
+            | SetGHC_XY   -- ^ ghc-x.y
+            | SetGHC_XYZ  -- ^ ghc-x.y.z
             deriving (Eq, Show)
 
 
-data Tag = Latest
-         | Recommended
-         deriving (Ord, Eq, Show)
-
-data VersionInfo = VersionInfo
-  { _viTags     :: [Tag]              -- ^ version specific tag
-  , _viSourceDL :: Maybe DownloadInfo -- ^ source tarball
-  , _viArch     :: ArchitectureSpec   -- ^ descend for binary downloads per arch
-  }
-  deriving (Eq, Show)
-
-data DownloadInfo = DownloadInfo
-  { _dlUri    :: URI
-  , _dlSubdir :: Maybe (Path Rel)
-  , _dlHash   :: Text
-  }
-  deriving (Eq, Show)
-
-data Tool = GHC
-          | Cabal
-          | GHCup
-  deriving (Eq, GHC.Generic, Ord, Show)
-
-data Architecture = A_64
-                  | A_32
-  deriving (Eq, GHC.Generic, Ord, Show)
-
-data LinuxDistro = Debian
-                 | Ubuntu
-                 | Mint
-                 | Fedora
-                 | CentOS
-                 | RedHat
-                 | Alpine
-                 | AmazonLinux
-                 -- rolling
-                 | Gentoo
-                 | Exherbo
-                 -- not known
-                 | UnknownLinux
-                 -- ^ must exit
-  deriving (Eq, GHC.Generic, Ord, Show)
-
-data Platform = Linux LinuxDistro
-              -- ^ must exit
-              | Darwin
-              -- ^ must exit
-              | FreeBSD
-  deriving (Eq, GHC.Generic, Ord, Show)
-
 data PlatformResult = PlatformResult
   { _platform      :: Platform
   , _distroVersion :: Maybe Versioning
@@ -101,13 +142,3 @@ data PlatformRequest = PlatformRequest
   }
   deriving (Eq, Show)
 
-type PlatformVersionSpec = Map (Maybe Versioning) DownloadInfo
-type PlatformSpec = Map Platform PlatformVersionSpec
-type ArchitectureSpec = Map Architecture PlatformSpec
-type ToolVersionSpec = Map Version VersionInfo
-type GHCupDownloads = Map Tool ToolVersionSpec
-
-data URLSource = GHCupURL
-               | OwnSource URI
-               | OwnSpec GHCupDownloads
-               deriving Show

lib/GHCup/Utils/File.hs

@@ -219,9 +219,9 @@ toProcessError exe args mps = case mps of
 -- | Convert the String to a ByteString with the current
 -- system encoding.
 unsafePathToString :: Path b -> IO FilePath
-unsafePathToString (Path p) = do
+unsafePathToString p = do
   enc <- getLocaleEncoding
-  unsafeUseAsCStringLen p (peekCStringLen enc)
+  unsafeUseAsCStringLen (toFilePath p) (peekCStringLen enc)
 
 
 -- | Search for a file in the search paths.