diff options
Diffstat (limited to 'src/main/frege/buildclient')
-rw-r--r-- | src/main/frege/buildclient/config/BuildConfig.fr | 18 | ||||
-rw-r--r-- | src/main/frege/buildclient/tasks/Executor.fr | 111 | ||||
-rw-r--r-- | src/main/frege/buildclient/util/concurrency.fr | 1 |
3 files changed, 129 insertions, 1 deletions
diff --git a/src/main/frege/buildclient/config/BuildConfig.fr b/src/main/frege/buildclient/config/BuildConfig.fr index 603f1a8..7c3290f 100644 --- a/src/main/frege/buildclient/config/BuildConfig.fr +++ b/src/main/frege/buildclient/config/BuildConfig.fr @@ -46,14 +46,30 @@ expectNumber :: ASTValue -> Maybe Int expectNumber (ASTValue.ASTNumber num) = Just num expectNumber _ = Nothing +maybeOr :: a -> Maybe a -> a +maybeOr _ (Just x) = x +maybeOr x Nothing = x -data BuildSource = GitSource {upstream :: String, branch :: Maybe String} + +data ArchiveFormat = Zip +derive Show ArchiveFormat + +data BuildSource = + GitSource {upstream :: String, branch :: Maybe String} + | HttpSource { url::String, format :: ArchiveFormat, archiveRoot :: Maybe String, skipDirs :: Int } derive Show BuildSource findSource :: ASTDirective -> Either String BuildSource findSource (ASTDirective _ [ASTWord "git"] block) = do upstream <- getTypedArg "upstream" "git upstream directive" block expectString return $ GitSource upstream (getArgDirective "branch" block >>= expectString) +findSource (ASTDirective _ [ASTWord "http"] block) = + do + url <- getTypedArg "url" "url" block expectString + format <- getTypedArg "format" "format" block (\x -> toString x >>= parseFormat) + return $ HttpSource url format (getArgDirective "root" block >>= expectString) $ maybeOr 0 (getArgDirective "skipDirs" block >>= expectNumber) + where parseFormat "zip" = Just ArchiveFormat.Zip + parseFormat _ = Nothing findSource (ASTDirective _ [ASTWord name] _) = fail ("Unknown source type " ++ name) findSource _ = fail "Please provide a source type" diff --git a/src/main/frege/buildclient/tasks/Executor.fr b/src/main/frege/buildclient/tasks/Executor.fr new file mode 100644 index 0000000..da17d89 --- /dev/null +++ b/src/main/frege/buildclient/tasks/Executor.fr @@ -0,0 +1,111 @@ +module buildclient.tasks.Executor where + + +import buildclient.config.BuildConfig +import frege.java.Net +import frege.java.IO +import Data.Array + + +data HttpURLConnection = native java.net.HttpURLConnection where + -- Unchecked cast, but who cares + native fromUrlConnection "(java.net.HttpURLConnection)" :: MutableIO URLConnection -> IOMutable HttpURLConnection + native setRequestProperty :: MutableIO HttpURLConnection -> String -> String -> IO () + native getHeaderField :: MutableIO HttpURLConnection -> String -> IO (Maybe String) + native getResponseCode :: MutableIO HttpURLConnection -> IO Int throws IOException + +data ZipEntry = native java.util.zip.ZipEntry where + native getName :: Mutable s ZipEntry -> ST s String + native isDirectory :: Mutable s ZipEntry -> ST s Bool + +data ZipInputStream = native java.util.zip.ZipInputStream where + native new :: MutableIO InputStream -> IOMutable ZipInputStream + native getNextEntry :: MutableIO ZipInputStream -> IO (Maybe (MutableIO ZipEntry)) throws IOException + native closeEntry :: MutableIO ZipInputStream -> IO () throws IOException + +bcDownloadSync :: File -> BuildSource -> IO () +bcDownloadSync targetDirectory (HttpSource url format archiveRoot skipDirs) = do + File.mkdirs targetDirectory + + let etagFile = File.new targetDirectory "etag.txt" + oldEtagExists <- File.exists etagFile + oldEtag <- if oldEtagExists then readFileStr etagFile else pure "" + + parsedUrl <- URL.new url + conn <- URL.openConnection parsedUrl >>= (HttpURLConnection.fromUrlConnection) + HttpURLConnection.setRequestProperty conn "If-None-Match" oldEtag + + -- Get InputStream early to trigger communication with server -> load response headers + inputStream <- URLConnection.getInputStream conn + + newEtag <- HttpURLConnection.getHeaderField conn "etag" + maybe (return ()) (writeFileStr etagFile) newEtag + resp <- HttpURLConnection.getResponseCode conn + case resp of + 304 = return () -- 304 indicated etag hit + 200 = do + let archiveFile = File.new targetDirectory "archive.zip" + saveInputStreamTo inputStream $ archiveFile + extractZip skipDirs archiveFile $ File.new targetDirectory "archive-extracted" + otherwise = fail ("Server replied with unexpected http code " ++ show resp) + + return () + + +extractZip :: Int -> File -> File -> IO () +extractZip skipDirs archiveFile targetDirectory = + do + File.mkdirs targetDirectory + fis <- FileInputStream.new archiveFile + zis <- ZipInputStream.new fis + extractFiles zis + return () + where + extractFiles zis = do + entry <- ZipInputStream.getNextEntry zis + case entry of + Just n -> extractFile zis n >> extractFiles zis + Nothing -> return () + extractFile zis zentry = do + isdir <- ZipEntry.isDirectory zentry + if isdir + then return () + else do + name <- ZipEntry.getName zentry + let (Right pattern) = Regex.compile "[/\\\\]" + let parts = drop skipDirs $ toList $ Regex.split (pattern) name + let targetFile = fold File.new targetDirectory parts + maybe (return false) File.mkdirs $ File.getParentFile targetFile + saveInputStreamTo zis targetFile + return () + +writeFileStr :: File -> String -> IO () +writeFileStr file text = do + fos <- FileOutputStream.new file + osw <- OutputStreamWriter.new fos "UTF-8" + osw.write text + osw.close + +readFileStr :: File -> IO String +readFileStr file = do + fis <- FileInputStream.new file + isr <- InputStreamReader.new fis "UTF-8" + getContentsOf isr + +saveInputStreamTo :: MutableIO InputStream -> File -> IO () +saveInputStreamTo is file = + do maybe (return false) File.mkdirs $ File.getParentFile file + fos <- FileOutputStream.new file + arr <- newArray 4096 + copyloop arr fos + fos.close + return () + where + copyloop :: ArrayOf RealWorld Byte -> MutableIO FileOutputStream -> IO () + copyloop buf to = do + rc <- InputStream.read is buf + if rc < 0 + then return () + else do + OutputStream.write to buf 0 rc + copyloop buf to diff --git a/src/main/frege/buildclient/util/concurrency.fr b/src/main/frege/buildclient/util/concurrency.fr new file mode 100644 index 0000000..a136ff1 --- /dev/null +++ b/src/main/frege/buildclient/util/concurrency.fr @@ -0,0 +1 @@ +module buildclient.util.concurrency where |