yackage 0.0.0 → 0.0.1
raw patch · 3 files changed
+109/−17 lines, 3 filesdep +blaze-builderdep +cmdargsdep +http-enumeratornew-component:exe:yackage-upload
Dependencies added: blaze-builder, cmdargs, http-enumerator, wai, wai-extra
Files
- yackage-upload.hs +49/−0
- yackage.cabal +9/−1
- yackage.hs +51/−16
+ yackage-upload.hs view
@@ -0,0 +1,49 @@+{-# LANGUAGE OverloadedStrings #-}+import Network.HTTP.Enumerator+import System.Environment+import qualified Data.ByteString.Lazy as L+import Blaze.ByteString.Builder+import Blaze.ByteString.Builder.Char.Utf8 (fromString)+import Data.Monoid (mconcat)+import qualified Data.ByteString.Char8 as S8++main = do+ args <- getArgs+ let (url, pass, file) =+ case args of+ [x, y] -> (x, "", y)+ [x, y, z] -> (x, y, z)+ _ -> error "Usage: yackage-upload <url> [password] <file>"+ req <- parseUrl url+ body <- mkBody pass file+ let req' = req+ { method = "POST"+ , requestHeaders =+ [ ("Content-Type", "multipart/form-data; boundary=" `S8.append` bound)+ , ("Content-Length", S8.pack $ show $ L.length body)+ ]+ , requestBody = body+ }+ res <- httpLbs req'+ L.putStrLn $ responseBody res++bound = "YACKAGEUPLOAD"++mkBody pass file = do+ file' <- L.readFile file+ let boundary = fromByteString bound+ return $ toLazyByteString $ mconcat+ [ fromByteString "--"+ , boundary+ , fromByteString "\r\nContent-Disposition: form-data; name=\"password\"\r\nContent-Type: text/plain\r\n\r\n"+ , fromString pass+ , fromByteString "\r\n--"+ , boundary+ , fromByteString "\r\nContent-Disposition: form-data; name=\"file\"; filename=\""+ , fromString file+ , fromByteString "\"\r\nContent-Type: application/x-tar\r\n\r\n"+ , fromLazyByteString file'+ , fromByteString "\r\n--"+ , boundary+ , fromByteString "--\r\n"+ ]
yackage.cabal view
@@ -1,5 +1,5 @@ Name: yackage-Version: 0.0.0+Version: 0.0.1 Synopsis: Personal Hackage replacement for testing new packages. Description: This package installs a yackage executable that runs a simplistic hackage-like server. It allows you to upload packages produced via cabal sdist and install them via cabal. The trick is to add the yackage repository to your cabal config file, with a line such as:@@ -28,6 +28,14 @@ , directory , data-object , data-object-yaml+ , cmdargs+ , wai+ , wai-extra++Executable yackage-upload+ Main-is: yackage-upload.hs+ Build-depends: http-enumerator >= 0.2 && < 0.3+ , blaze-builder >= 0.2.1.3 && < 0.3 source-repository head type: git
yackage.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE OverloadedStrings, TypeFamilies, QuasiQuotes #-}+{-# LANGUAGE DeriveDataTypeable #-} import Yesod import Distribution.Package import Distribution.PackageDescription@@ -24,14 +25,25 @@ import Data.Maybe (fromMaybe) import Data.Object import Data.Object.Yaml-import Control.Monad (join)+import Control.Monad (join, unless)+import System.Console.CmdArgs+import Network.Wai+import Network.Wai.Handler.SimpleServer (run) +data Args = Args+ { port :: Int+ , password :: Maybe String+ , localhost :: Bool+ , rootdir :: Maybe String+ } deriving (Show, Data, Typeable)+ type CabalFile = FilePath type Tarball = FilePath data Yackage = Yackage { rootDir :: FilePath , packages :: MVar PackageDB+ , ypassword :: Maybe String } type PackageDB = Map PackageName (Set Version)@@ -82,15 +94,22 @@ getRootR :: Handler RepHtml getRootR = do+ y <- getYesod ps <- getYesod >>= liftIO . readMVar . packages >>= return . Map.toList defaultLayout $ do setTitle "Yackage" addHamlet [$hamlet| %h1 Yackage %form!method=post!enctype=multipart/form-data- Upload a new file: $- %input!type=file!name=file- %input!type=submit!value=Upload+ %div+ Upload a new file: $+ %input!type=file!name=file+ $maybe ypassword.y _+ %div+ Password: $+ %input!type=password!name=password+ %div+ %input!type=submit!value=Upload %dl $forall ps p %dt $unPackageName.fst.p$@@ -101,11 +120,17 @@ |] postRootR = do+ y <- getYesod+ case ypassword y of+ Nothing -> return ()+ Just p -> do+ p' <- runFormPost' $ maybeStringInput "password"+ unless (Just p == p') $ permissionDenied "Invalid password" rr <- getRequest (_, files) <- liftIO $ reqRequestBody rr content <- case lookup "file" files of- Nothing -> notFound+ Nothing -> error "No file upload found" Just fi -> return $ fileContent fi let entries = Tar.read $ decompress content let cabal =@@ -155,16 +180,17 @@ return () main = do- path <- getAppUserDataDirectory "yackage"- x <- getArgs- port <-- case x of- [] -> return 3500- [y] ->- case reads y of- [] -> error $ "Invalid port: " ++ y- (z, _):_ -> return z- _ -> error "Usage: yackage [port number]"+ progname <- getProgName+ args <- cmdArgsRun $ cmdArgsMode $ Args+ { port = 3500 &= help "Port number"+ , password = Nothing &= help "Optional password required to upload files"+ , localhost = False &= help "Only allow connections from localhost?"+ , rootdir = Nothing &= help "Root folder for Yackage config file and packages"+ } &= program progname &= summary "Run a Yackage server"+ path <-+ case rootdir args of+ Nothing -> getAppUserDataDirectory "yackage"+ Just s -> return s createDirectoryIfMissing True $ path ++ "/package" let config = path ++ "/config.yaml" e <- doesFileExist config@@ -172,7 +198,16 @@ then parseConfig `fmap` join (decodeFile config) else return $ Map.empty m' <- liftIO $ newMVar m- basicHandler port $ Yackage path m'+ app <- toWaiApp $ Yackage path m' $ password args+ let app' = if localhost args then onlyLocal app else app+ putStrLn $ "Running Yackage on port " ++ show (port args) ++ ", rootdir: " ++ path+ run (port args) app'++onlyLocal app req =+ if remoteHost req `elem` ["127.0.0.1", "::1", "localhost"]+ then app req+ else return $ Response status403 [("Content-Type", "text/plain")]+ $ ResponseLBS "This Yackage server only talks to local clients" unPackageName (PackageName s) = s