Fix all warnings

This commit is contained in:
Michael Snoyman 2014-07-30 12:10:45 +03:00
parent e2ca5dcfd6
commit 85939d1631
13 changed files with 45 additions and 37 deletions

View File

@ -72,8 +72,8 @@ makeApplication echo@True conf = do
}
Echo.clear
return (logWare (defaultMiddlewaresNoLogging app),logFunc)
where logFunc (Loc filename _pkg _mod (line,_) _) source level str =
Echo.write (filename,line) (show source ++ ": " ++ show level ++ ": " ++ toStr str)
where logFunc (Loc filename' _pkg _mod (line,_) _) source level str =
Echo.write (filename',line) (show source ++ ": " ++ show level ++ ": " ++ toStr str)
toStr = unpack . decodeUtf8 . fromLogStr
makeApplication echo@False conf = do
foundation <- makeFoundation echo conf

View File

@ -91,6 +91,7 @@ fileStore root = BlobStore
, storeExists' = liftIO . F.isFile . toFP root
}
toFP :: ToPath a => FilePath -> a -> FilePath
toFP root key = foldl' (\x y -> x </> fpFromText y) root (toPath key)
-- | Note: Only use with data which will never be modified!

View File

@ -17,7 +17,6 @@ import qualified Codec.Archive.Tar as Tar
import Control.Monad.Reader (MonadReader, ask)
import qualified Data.Text as T
import Data.Conduit.Zlib (ungzip, gzip)
import Text.XML.Cursor (($//), (&/), content, fromDocument, element, followingSibling)
import System.IO.Temp (withSystemTempFile, withSystemTempDirectory)
import System.IO (IOMode (ReadMode), openBinaryFile)
import Control.Monad.Catch (MonadMask)
@ -25,9 +24,9 @@ import Model (Uploaded (Uploaded))
import Filesystem (createTree)
import Distribution.PackageDescription.Parse (parsePackageDescription, ParseResult (ParseOk))
import Distribution.PackageDescription.PrettyPrint (showGenericPackageDescription)
import Distribution.PackageDescription (GenericPackageDescription, PackageDescription, packageDescription)
import Distribution.PackageDescription (GenericPackageDescription)
import Control.Exception (throw)
import Control.Monad.State.Strict (modify, put, get, execStateT, MonadState)
import Control.Monad.State.Strict (put, get, execStateT, MonadState)
sinkUploadHistory :: Monad m => Consumer (Entity Uploaded) m UploadHistory
sinkUploadHistory =
@ -77,6 +76,9 @@ loadCabalFiles uploadHistory0 = flip execStateT (UploadState uploadHistory0 [])
setUploadDate name version
_ -> return ()
tarSource :: (Exception e, MonadThrow m)
=> Tar.Entries e
-> Producer m Tar.Entry
tarSource Tar.Done = return ()
tarSource (Tar.Fail e) = throwM e
tarSource (Tar.Next e es) = yield e >> tarSource es
@ -123,11 +125,6 @@ setUploadDate name version = do
, "/upload-time"
]
hasContent t c =
if T.concat (c $// content) == t
then [c]
else []
parseFilePath :: String -> Maybe (PackageName, Version)
parseFilePath s =
case filter (not . null) $ T.split (== '/') $ pack s of
@ -262,16 +259,16 @@ createView viewName modifyCabal src sink = withSystemTempDirectory "createview"
key = HackageViewCabal viewName name version
mprev <- storeRead key
case mprev of
Just src -> do
Just src' -> do
liftIO $ createTree $ directory fp
src $$ sinkFile fp
src' $$ sinkFile fp
return $ asSet $ singletonSet relfp
Nothing -> do
msrc <- storeRead $ HackageCabal name version
case msrc of
Nothing -> return mempty
Just src -> do
orig <- src $$ sinkLazy
Just src' -> do
orig <- src' $$ sinkLazy
new <-
case parsePackageDescription $ unpack $ decodeUtf8 orig of
ParseOk _ gpd -> do
@ -299,6 +296,10 @@ sourceHistory =
go' (version, time) = yield $ Uploaded name version time
-- FIXME put in conduit-combinators
parMapMC :: (MonadIO m, MonadBaseControl IO m)
=> Int
-> (i -> m o)
-> Conduit i m o
parMapMC _ = mapMC
{- FIXME
parMapMC :: (MonadIO m, MonadBaseControl IO m)

View File

@ -1,3 +1,4 @@
{-# OPTIONS_GHC -fno-warn-warnings-deprecations #-}
module Data.Hackage.Views where
import ClassyPrelude.Yesod
@ -8,6 +9,7 @@ import Distribution.Text (simpleParse)
import Data.NonNull (fromNullable) -- FIXME expose from ClassyPrelude
import Data.Hackage (UploadHistory)
import Data.Time (addUTCTime)
import qualified Types
viewUnchanged :: Monad m
=> packageName -> version -> time
@ -62,6 +64,10 @@ viewNoBounds _ _ _ =
where
go (Dependency name _range) = return $ Dependency name anyVersion
getAvailable :: Types.PackageName
-> UTCTime
-> HashMap Types.PackageName (HashMap Types.Version UTCTime)
-> [Types.Version]
getAvailable name maxUploaded =
map fst . filter ((<= maxUploaded) . snd) . mapToList . fromMaybe mempty . lookup name
@ -71,6 +77,7 @@ getAvailable name maxUploaded =
-- technically it "wasn't available" yet.
--
-- The actual value we should use is up for debate. I'm starting with 24 hours.
addFuzz :: UTCTime -> UTCTime
addFuzz = addUTCTime (60 * 60 * 24)
viewPVP :: Monad m

View File

@ -43,4 +43,5 @@ write (file,line) it =
loc = file ++ ":" ++ show line
fmt = formatTime defaultTimeLocale "%T%Q"
clear :: IO ()
clear = writeFile "/tmp/echo" ""

View File

@ -3,7 +3,6 @@ module Foundation where
import ClassyPrelude.Yesod
import Data.BlobStore
import Data.Slug (safeMakeSlug, HasGenIO (getGenIO), randomSlug, Slug)
import Data.Text (Text)
import qualified Database.Persist
import Model
import qualified Settings
@ -78,7 +77,6 @@ instance Yesod App where
"config/client_session_key.aes"
defaultLayout widget = do
master <- getYesod
mmsg <- getMessage
muser <- maybeAuth

View File

@ -2,7 +2,6 @@ module Handler.HackageViewSdist where
import Import
import Data.Hackage
import Data.Conduit.Lazy (MonadActive (..))
getHackageViewSdistR :: HackageView -> PackageNameVersion -> Handler TypedContent
getHackageViewSdistR viewName (PackageNameVersion name version) = do
@ -18,6 +17,3 @@ getHackageViewSdistR viewName (PackageNameVersion name version) = do
, ".tar.gz"
]
respondSource "application/x-gzip" $ mapOutput (Chunk . toBuilder) src
instance MonadActive m => MonadActive (HandlerT site m) where -- FIXME upstream
monadActive = lift monadActive

View File

@ -4,7 +4,7 @@ import Import
import Data.Slug (slugField)
userForm :: User -> Form User
userForm user = renderBootstrap $ User
userForm user = renderBootstrap2 $ User
<$> areq slugField "User handle"
{ fsTooltip = Just "Used for URLs"
} (Just $ userHandle user)

View File

@ -1,6 +1,6 @@
module Handler.UploadStackage where
import Import hiding (catch, get)
import Import hiding (catch, get, update)
import System.IO.Temp (withSystemTempFile, withSystemTempDirectory, openBinaryTempFile)
import Crypto.Hash.Conduit (sinkHash)
import Crypto.Hash (Digest, SHA1)
@ -14,7 +14,7 @@ import Data.BlobStore
import Filesystem (createTree)
import Control.Monad.State.Strict (execStateT, get, put)
import qualified Codec.Compression.GZip as GZip
import Control.Monad.Trans.Resource (unprotect, allocate)
import Control.Monad.Trans.Resource (allocate)
import System.Directory (removeFile, getTemporaryDirectory)
import System.Process (runProcess, waitForProcess)
import System.Exit (ExitCode (ExitSuccess))
@ -50,7 +50,7 @@ putUploadStackageR = do
malias <- lookupPostParam "alias"
tempDir <- liftIO getTemporaryDirectory
(releaseKey, (fp, handleOut)) <- allocate
(_releaseKey, (fp, handleOut)) <- allocate
(openBinaryTempFile tempDir "upload-stackage.")
(\(fp, h) -> hClose h `finally` removeFile fp)
digest <- fileSource file
@ -102,18 +102,18 @@ putUploadStackageR = do
, lsFiles = mempty
, lsIdent = ident
}
withSystemTempFile "newindex" $ \fp h -> do
withSystemTempFile "newindex" $ \fp' h -> do
ec <- liftIO $ do
hClose h
let args = "cfz"
: fp
: fp'
: map fpToString (setToList files)
ph <- runProcess "tar" args (Just dir) Nothing Nothing Nothing Nothing
waitForProcess ph
if ec == ExitSuccess
then do
sourceFile (fpFromString fp) $$ storeWrite (CabalIndex ident)
runDB $ insert stackage
sourceFile (fpFromString fp') $$ storeWrite (CabalIndex ident)
runDB $ insert_ stackage
setAlias
@ -130,7 +130,7 @@ putUploadStackageR = do
loop update entries
addEntry update entry = do
update $ "Processing file: " ++ pack (Tar.entryPath entry)
_ <- update $ "Processing file: " ++ pack (Tar.entryPath entry)
case Tar.entryContent entry of
Tar.NormalFile lbs _ ->
case filename $ fpFromString $ Tar.entryPath entry of
@ -150,7 +150,7 @@ putUploadStackageR = do
case parseName line of
Just (name, version) -> do
$logDebug $ "hackage: " ++ tshow (name, version)
update $ concat
_ <- update $ concat
[ "Adding Hackage package: "
, toPathPiece name
, "-"
@ -167,7 +167,7 @@ putUploadStackageR = do
, Just (name, version) <- parseName (fpToText base) -> do
ident <- lsIdent <$> get
sourceLazy lbs $$ storeWrite (CustomSdist ident name version)
update $ concat
_ <- update $ concat
[ "Extracting cabal file for custom tarball: "
, toPathPiece name
, "-"
@ -211,6 +211,11 @@ data LoopState = LoopState
, lsIdent :: !PackageSetIdent
}
extractCabal :: (MonadLogger m, MonadThrow m)
=> LByteString
-> PackageName -- ^ name
-> Version -- ^ version
-> m LByteString
extractCabal lbs name version =
loop $ Tar.read $ GZip.decompress lbs
where
@ -219,7 +224,7 @@ extractCabal lbs name version =
loop (Tar.Next e es) = do
$logDebug $ tshow (Tar.entryPath e, fp)
case Tar.entryContent e of
Tar.NormalFile lbs _ | Tar.entryPath e == fp -> return lbs
Tar.NormalFile lbs' _ | Tar.entryPath e == fp -> return lbs'
_ -> loop es
fp = unpack $ concat

View File

@ -3,7 +3,6 @@ module Import
) where
import ClassyPrelude.Yesod as Import
import Data.Text as Import (Text)
import Foundation as Import
import Model as Import
import Settings as Import

View File

@ -72,10 +72,10 @@ library
build-depends:
base >= 4 && < 5
, yesod >= 1.2.5 && < 1.3
, yesod-core >= 1.2.12 && < 1.3
, yesod-core >= 1.2.19 && < 1.3
, yesod-auth >= 1.3 && < 1.4
, yesod-static >= 1.2 && < 1.3
, yesod-form >= 1.3 && < 1.4
, yesod-form >= 1.3.14 && < 1.4
, bytestring >= 0.9 && < 0.11
, text >= 0.11 && < 2.0
, persistent >= 1.3.1 && < 1.4

View File

@ -4,7 +4,7 @@
of complete package sets. Think “stable Hackage”.
<h2 .recommended-snapshots>Recommended Snapshots
<ul .snapshots>
$forall (E.Value ident, E.Value title, E.Value uploaded, E.Value display, E.Value handle) <- stackages
$forall (E.Value ident, E.Value title, E.Value _uploaded, E.Value _display, E.Value _handle) <- stackages
<li>
<a href=@{StackageHomeR ident}>
#{title}

View File

@ -17,7 +17,7 @@ main = do
conf <- Yesod.Default.Config.loadConfig $ (configSettings Testing)
{ csParseExtra = parseExtra
}
foundation <- makeFoundation conf
foundation <- makeFoundation False conf
hspec $ do
Data.SlugSpec.spec
yesodSpec foundation $ do