mirror of
https://github.com/commercialhaskell/stackage-server.git
synced 2026-01-12 04:08:29 +01:00
Clean up warnings
This commit is contained in:
parent
01b86d368c
commit
fe4cda60f8
@ -9,12 +9,8 @@ module Application
|
||||
import qualified Aws
|
||||
import Control.Concurrent (forkIO, threadDelay)
|
||||
import Control.Exception (catch)
|
||||
import Control.Monad.Logger (runLoggingT, LoggingT, runStdoutLoggingT, defaultLogStr, LogLevel (LevelDebug))
|
||||
import Control.Monad.Reader (MonadReader (..))
|
||||
import Control.Monad.Reader (runReaderT, ReaderT)
|
||||
import Control.Monad.Trans.Control
|
||||
import Control.Monad.Logger (runLoggingT, LoggingT, defaultLogStr)
|
||||
import Data.BlobStore (fileStore, storeWrite, cachedS3Store)
|
||||
import Data.Conduit.Lazy (MonadActive, monadActive)
|
||||
import Data.Hackage
|
||||
import Data.Hackage.Views
|
||||
import Data.Time (diffUTCTime)
|
||||
|
||||
@ -11,9 +11,7 @@ module Data.BlobStore
|
||||
) where
|
||||
|
||||
import ClassyPrelude.Yesod
|
||||
import Control.Exception.Lifted (bracketOnError)
|
||||
import qualified Filesystem as F
|
||||
import Control.Monad.Reader (MonadReader, ask)
|
||||
import Control.Monad.Trans.Resource (release)
|
||||
import qualified Aws
|
||||
import Aws.S3 as Aws
|
||||
|
||||
@ -14,13 +14,11 @@ import Types
|
||||
import Data.BlobStore
|
||||
import Data.Conduit.Lazy (MonadActive (..), lazyConsume)
|
||||
import qualified Codec.Archive.Tar as Tar
|
||||
import Control.Monad.Reader (MonadReader, ask, runReaderT)
|
||||
import Control.Monad.Logger (runNoLoggingT)
|
||||
import qualified Data.Text as T
|
||||
import Data.Conduit.Zlib (ungzip, gzip)
|
||||
import System.IO.Temp (withSystemTempFile, withSystemTempDirectory)
|
||||
import System.IO (IOMode (ReadMode), openBinaryFile)
|
||||
import Control.Monad.Catch (MonadMask)
|
||||
import Model (Uploaded (Uploaded), Metadata (..))
|
||||
import Filesystem (createTree)
|
||||
import Distribution.PackageDescription.Parse (parsePackageDescription, ParseResult (ParseOk))
|
||||
|
||||
@ -13,7 +13,6 @@ module Data.Slug
|
||||
import ClassyPrelude.Yesod
|
||||
import Database.Persist.Sql (PersistFieldSql (sqlType))
|
||||
import qualified System.Random.MWC as MWC
|
||||
import Control.Monad.Reader (MonadReader, ask)
|
||||
import GHC.Prim (RealWorld)
|
||||
import Text.Blaze (ToMarkup)
|
||||
|
||||
@ -32,9 +31,9 @@ mkSlug t
|
||||
where
|
||||
|
||||
mkSlugLen :: MonadThrow m => Int -> Int -> Text -> m Slug
|
||||
mkSlugLen minLen maxLen t
|
||||
| length t < minLen = throwM $ InvalidSlugException t "Too short"
|
||||
| length t > maxLen = throwM $ InvalidSlugException t "Too long"
|
||||
mkSlugLen minLen' maxLen' t
|
||||
| length t < minLen' = throwM $ InvalidSlugException t "Too short"
|
||||
| length t > maxLen' = throwM $ InvalidSlugException t "Too long"
|
||||
| any (not . validChar) t = throwM $ InvalidSlugException t "Contains invalid characters"
|
||||
| "-" `isPrefixOf` t = throwM $ InvalidSlugException t "Must not start with a hyphen"
|
||||
| otherwise = return $ Slug t
|
||||
|
||||
@ -112,7 +112,7 @@ instance Yesod App where
|
||||
mcurr <- getCurrentRoute
|
||||
let notHome = mcurr /= Just HomeR
|
||||
|
||||
giveUrlRenderer $(hamletFile "templates/default-layout-wrapper.hamlet")
|
||||
withUrlRenderer $(hamletFile "templates/default-layout-wrapper.hamlet")
|
||||
|
||||
-- This is done to provide an optimization for serving static files from
|
||||
-- a separate domain. Please see the staticRoot setting in Settings.hs
|
||||
|
||||
@ -20,8 +20,6 @@ import Text.Email.Validate
|
||||
getPackageR :: PackageName -> Handler Html
|
||||
getPackageR pn = do
|
||||
let maxSnaps = 10
|
||||
asInt :: Int -> Int
|
||||
asInt = id
|
||||
haddocksLink ident version =
|
||||
HaddockR ident [concat [toPathPiece pn, "-", toPathPiece version]]
|
||||
muid <- maybeAuthId
|
||||
@ -38,8 +36,8 @@ getPackageR pn = do
|
||||
let getLiked uid = (>0) <$> count [LikePackage ==. pn, LikeVoter ==. uid]
|
||||
liked <- maybe (return False) getLiked muid
|
||||
downloads <- count [DownloadPackage ==. pn]
|
||||
now <- liftIO getCurrentTime
|
||||
let nowMinus30 = addUTCTime (-30 * 24 * 60 * 60) now
|
||||
now' <- liftIO getCurrentTime
|
||||
let nowMinus30 = addUTCTime (-30 * 24 * 60 * 60) now'
|
||||
recentDownloads <- count [DownloadPackage ==. pn, DownloadTimestamp >=. nowMinus30]
|
||||
metadata <- getBy404 (UniqueMetadata pn)
|
||||
|
||||
|
||||
@ -17,8 +17,8 @@ import Import
|
||||
-- inclined, or create a single monolithic file.
|
||||
getAllSnapshotsR :: Handler Html
|
||||
getAllSnapshotsR = do
|
||||
now <- liftIO getCurrentTime
|
||||
groups <- fmap (groupBy (on (==) (\(_,_,uploaded,_,_) -> uploaded)) . map (uncrapify now)) $
|
||||
now' <- liftIO getCurrentTime
|
||||
groups <- fmap (groupBy (on (==) (\(_,_,uploaded,_,_) -> uploaded)) . map (uncrapify now')) $
|
||||
runDB $ E.select $ E.from $ \(stackage `E.InnerJoin` user) -> do
|
||||
E.on (stackage E.^. StackageUser E.==. user E.^. UserId)
|
||||
E.orderBy [E.desc $ stackage E.^. StackageUploaded]
|
||||
@ -32,6 +32,6 @@ getAllSnapshotsR = do
|
||||
defaultLayout $ do
|
||||
setTitle "Stackage Server"
|
||||
$(widgetFile "all-snapshots")
|
||||
where uncrapify now c =
|
||||
let (E.Value ident, E.Value title, E.Value uploaded, E.Value display, E.Value handle) = c
|
||||
in (ident,title,format (diff True) (diffUTCTime uploaded now),display,handle)
|
||||
where uncrapify now' c =
|
||||
let (E.Value ident, E.Value title, E.Value uploaded, E.Value display, E.Value handle') = c
|
||||
in (ident,title,format (diff True) (diffUTCTime uploaded now'),display,handle')
|
||||
|
||||
@ -2,7 +2,6 @@ module Handler.StackageIndex where
|
||||
|
||||
import Import
|
||||
import Data.BlobStore
|
||||
import Network.Wai (responseBuilder)
|
||||
|
||||
getStackageIndexR :: PackageSetIdent -> Handler TypedContent
|
||||
getStackageIndexR ident = do
|
||||
|
||||
@ -5,7 +5,7 @@
|
||||
<h3>
|
||||
#{uploaded}
|
||||
<ul .snapshots>
|
||||
$forall (ident, title, uploaded, display, handle) <- stackages
|
||||
$forall (ident, title, _uploaded, display, handle) <- stackages
|
||||
<li>
|
||||
<strong>
|
||||
<a href=@{StackageHomeR ident}>
|
||||
|
||||
Loading…
Reference in New Issue
Block a user