├── .authorspellings ├── .gitignore ├── BuildClient.hs ├── Data ├── IntTrie.hs ├── StringTable.hs └── TarIndex.hs ├── Distribution ├── Client.hs ├── Server.hs └── Server │ ├── Acid.hs │ ├── Features.hs │ ├── Features │ ├── BuildReports.hs │ ├── BuildReports │ │ ├── Backup.hs │ │ ├── BuildReport.hs │ │ ├── BuildReports.hs │ │ └── State.hs │ ├── Check.hs │ ├── Core.hs │ ├── Distro.hs │ ├── Distro │ │ ├── Backup.hs │ │ ├── Distributions.hs │ │ ├── State.hs │ │ └── Types.hs │ ├── Documentation.hs │ ├── DownloadCount.hs │ ├── HaskellPlatform.hs │ ├── Html.hs │ ├── LegacyRedirects.hs │ ├── Mirror.hs │ ├── NameSearch.hs │ ├── PackageContents.hs │ ├── PackageList.hs │ ├── Packages.hs │ ├── PreferredVersions.hs │ ├── ReverseDependencies.hs │ ├── StaticFiles.hs │ ├── Tags.hs │ ├── Upload.hs │ └── Users.hs │ ├── Framework.hs │ ├── Framework │ ├── Auth.hs │ ├── AuthCrypt.hs │ ├── AuthTypes.hs │ ├── BackupDump.hs │ ├── BackupRestore.hs │ ├── BlobStorage.hs │ ├── Cache.hs │ ├── Error.hs │ ├── Feature.hs │ ├── Hook.hs │ ├── Instances.hs │ ├── Resource.hs │ ├── ResourceTypes.hs │ └── Types.hs │ ├── LegacyImport │ ├── BulkImport.hs │ ├── HtPasswdDb.hs │ └── UploadLog.hs │ ├── Packages │ ├── Backup.hs │ ├── Backup │ │ ├── Downloads.hs │ │ └── Tags.hs │ ├── Downloads.hs │ ├── Index.hs │ ├── ModuleForest.hs │ ├── PackageIndex.hs │ ├── Platform.hs │ ├── Preferred.hs │ ├── Reverse.hs │ ├── State.hs │ ├── Tag.hs │ ├── Types.hs │ └── Unpack.hs │ ├── Pages │ ├── BuildReports.hs │ ├── Distributions.hs │ ├── Group.hs │ ├── Index.hs │ ├── Package.hs │ ├── Package │ │ ├── HaddockHtml.hs │ │ ├── HaddockLex.x │ │ └── HaddockParse.y │ ├── Recent.hs │ ├── Reverse.hs │ ├── Template.hs │ └── Util.hs │ ├── Users │ ├── Backup.hs │ ├── Group.hs │ ├── State.hs │ ├── Types.hs │ └── Users.hs │ └── Util │ ├── ActionLog.hs │ ├── AsyncVar.hs │ ├── ChangeLog.hs │ ├── ContentType.hs │ ├── Happstack.hs │ ├── Histogram.hs │ ├── Index.hs │ ├── Merge.hs │ ├── NameIndex.hs │ ├── Parse.hs │ ├── ServeTarball.hs │ ├── TarIndex.hs │ ├── TextSearch.hs │ └── TimeLogger.hs ├── LICENSE ├── Main.hs ├── MirrorClient.hs ├── README.md ├── TODO ├── hackage-server.cabal ├── static ├── accounts.html ├── admin.html ├── built-with-cabal.png ├── cabal-tiny.png ├── favicon.ico ├── hackage.css ├── hackage.html ├── haddock │ ├── haddock-util.js │ ├── haskell_icon.gif │ ├── hslogo-16.png │ ├── minus.gif │ ├── ocean.css │ ├── plus.gif │ ├── synopsis.png │ └── xhaddock.css └── upload.html └── tests └── TarCheck.hs /.authorspellings: -------------------------------------------------------------------------------- 1 | Antoine Latter 2 | Matthew Gruen 3 | 4 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | dist 2 | *.hi 3 | *.o 4 | 5 | -------------------------------------------------------------------------------- /Data/StringTable.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveDataTypeable, TemplateHaskell #-} 2 | 3 | module Data.StringTable {-( 4 | 5 | StringTable, 6 | lookup, 7 | index, 8 | construct, 9 | 10 | prop, 11 | 12 | )-} where 13 | 14 | import Prelude hiding (lookup) 15 | import qualified Data.List as List 16 | import qualified Data.Array.Unboxed as A 17 | import Data.Array.Unboxed ((!)) 18 | import Data.SafeCopy (base, deriveSafeCopy) 19 | import Data.Typeable (Typeable) 20 | import qualified Data.ByteString.Char8 as BS 21 | import Data.Word (Word32) 22 | 23 | import Distribution.Server.Framework.Instances() 24 | 25 | -- | An effecient mapping from strings to a dense set of integers. 26 | -- 27 | data Enum id => StringTable id 28 | = StringTable 29 | !BS.ByteString -- all the strings concatenated 30 | !(A.UArray Int Word32) -- offset table 31 | deriving (Show, Typeable) 32 | 33 | $(deriveSafeCopy 0 'base ''StringTable) 34 | 35 | -- | Look up a string in the token table. If the string is present, return 36 | -- its corresponding index. 37 | -- 38 | lookup :: Enum id => StringTable id -> String -> Maybe id 39 | lookup (StringTable bs tbl) str = binarySearch 0 (topBound-1) (BS.pack str) 40 | where 41 | (0, topBound) = A.bounds tbl 42 | 43 | binarySearch a b key 44 | | a > b = Nothing 45 | | otherwise = case compare key (index' bs tbl mid) of 46 | LT -> binarySearch a (mid-1) key 47 | EQ -> Just (toEnum mid) 48 | GT -> binarySearch (mid+1) b key 49 | where mid = (a + b) `div` 2 50 | 51 | index' :: BS.ByteString -> A.UArray Int Word32 -> Int -> BS.ByteString 52 | index' bs tbl i = BS.take len . BS.drop start $ bs 53 | where 54 | start, end, len :: Int 55 | start = fromIntegral (tbl ! i) 56 | end = fromIntegral (tbl ! (i+1)) 57 | len = end - start 58 | 59 | 60 | -- | Given the index of a string in the table, return the string. 61 | -- 62 | index :: Enum id => StringTable id -> id -> String 63 | index (StringTable bs tbl) = BS.unpack . index' bs tbl . fromEnum 64 | 65 | 66 | -- | Given a list of strings, construct a 'StringTable' mapping those strings 67 | -- to a dense set of integers. 68 | -- 69 | construct :: Enum id => [String] -> StringTable id 70 | construct strs = StringTable bs tbl 71 | where 72 | bs = BS.pack (concat strs') 73 | tbl = A.array (0, length strs') (zip [0..] offsets) 74 | offsets = scanl (\off str -> off + fromIntegral (length str)) 0 strs' 75 | strs' = map head . List.group . List.sort $ strs 76 | 77 | 78 | enumStrings :: Enum id => StringTable id -> [String] 79 | enumStrings (StringTable bs tbl) = map (BS.unpack . index' bs tbl) [0..h-1] 80 | where (0,h) = A.bounds tbl 81 | 82 | 83 | enumIds :: Enum id => StringTable id -> [id] 84 | enumIds (StringTable _ tbl) = map toEnum [0..h-1] 85 | where (0,h) = A.bounds tbl 86 | 87 | prop :: [String] -> Bool 88 | prop strs = 89 | all lookupIndex (enumStrings tbl) 90 | && all indexLookup (enumIds tbl) 91 | 92 | where 93 | tbl :: StringTable Int 94 | tbl = construct strs 95 | 96 | lookupIndex str = index tbl ident == str 97 | where Just ident = lookup tbl str 98 | 99 | indexLookup ident = lookup tbl str == Just ident 100 | where str = index tbl ident 101 | -------------------------------------------------------------------------------- /Data/TarIndex.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE GeneralizedNewtypeDeriving, DeriveDataTypeable, TemplateHaskell #-} 3 | 4 | module Data.TarIndex {-( 5 | 6 | TarIndex, 7 | TarIndexEntry(..), 8 | TarEntryOffset, 9 | 10 | lookup, 11 | construct, 12 | 13 | prop_lookup, prop, 14 | 15 | )-} where 16 | 17 | import Data.SafeCopy (base, deriveSafeCopy) 18 | import Data.Typeable (Typeable) 19 | 20 | import qualified Data.StringTable as StringTable 21 | import Data.StringTable (StringTable) 22 | import qualified Data.IntTrie as IntTrie 23 | 24 | import Data.IntTrie (IntTrie) 25 | import qualified System.FilePath as FilePath 26 | import Prelude hiding (lookup) 27 | 28 | -- | An index of the entries in a tar file. This lets us look up a filename 29 | -- within the tar file and find out where in the tar file (ie the file offset) 30 | -- that entry occurs. 31 | -- 32 | data TarIndex = TarIndex 33 | 34 | -- As an example of how the mapping works, consider these example files: 35 | -- "foo/bar.hs" at offset 0 36 | -- "foo/baz.hs" at offset 1024 37 | -- 38 | -- We split the paths into components and enumerate them. 39 | -- { "foo" -> TokenId 0, "bar.hs" -> TokenId 1, "baz.hs" -> TokenId 2 } 40 | -- 41 | -- We convert paths into sequences of 'TokenId's, i.e. 42 | -- "foo/bar.hs" becomes [PathComponentId 0, PathComponentId 1] 43 | -- "foo/baz.hs" becomes [PathComponentId 0, PathComponentId 2] 44 | -- 45 | -- We use a trie mapping sequences of 'PathComponentId's to the entry offset: 46 | -- { [PathComponentId 0, PathComponentId 1] -> offset 0 47 | -- , [PathComponentId 0, PathComponentId 1] -> offset 1024 } 48 | 49 | -- | The mapping of filepath components as strings to ids. 50 | !(StringTable PathComponentId) 51 | 52 | -- Mapping of sequences of filepath component ids to tar entry offsets. 53 | !(IntTrie PathComponentId TarEntryOffset) 54 | deriving (Show, Typeable) 55 | 56 | 57 | data TarIndexEntry = TarFileEntry !TarEntryOffset 58 | | TarDir [FilePath] 59 | deriving (Show, Typeable) 60 | 61 | 62 | newtype PathComponentId = PathComponentId Int 63 | deriving (Eq, Ord, Enum, Show, Typeable) 64 | 65 | type TarEntryOffset = Int 66 | 67 | $(deriveSafeCopy 0 'base ''TarIndex) 68 | $(deriveSafeCopy 0 'base ''PathComponentId) 69 | $(deriveSafeCopy 0 'base ''TarIndexEntry) 70 | 71 | -- | Look up a given filepath in the index. It may return a 'TarFileEntry' 72 | -- containing the offset and length of the file within the tar file, or if 73 | -- the filepath identifies a directory then it returns a 'TarDir' containing 74 | -- the list of files within that directory. 75 | -- 76 | lookup :: TarIndex -> FilePath -> Maybe TarIndexEntry 77 | lookup (TarIndex pathTable pathTrie) path = 78 | case toComponentIds pathTable path of 79 | Nothing -> Nothing 80 | Just fpath -> fmap (mkIndexEntry fpath) (IntTrie.lookup pathTrie fpath) 81 | where 82 | mkIndexEntry _ (IntTrie.Entry offset) = TarFileEntry offset 83 | mkIndexEntry _ (IntTrie.Completions entries) = 84 | TarDir [ fromComponentIds pathTable [entry] 85 | | entry <- entries ] 86 | 87 | -- | Construct a 'TarIndex' from a list of filepaths and their corresponding 88 | -- 89 | construct :: [(FilePath, TarEntryOffset)] -> TarIndex 90 | construct pathsOffsets = TarIndex pathTable pathTrie 91 | where 92 | pathComponents = concatMap (FilePath.splitDirectories . fst) pathsOffsets 93 | pathTable = StringTable.construct pathComponents 94 | pathTrie = IntTrie.construct 95 | [ (cids, offset) 96 | | (path, offset) <- pathsOffsets 97 | , let Just cids = toComponentIds pathTable path ] 98 | 99 | toComponentIds :: StringTable PathComponentId -> FilePath -> Maybe [PathComponentId] 100 | toComponentIds table = lookupComponents [] . FilePath.splitDirectories 101 | where 102 | lookupComponents cs' [] = Just (reverse cs') 103 | lookupComponents cs' (c:cs) = case StringTable.lookup table c of 104 | Nothing -> Nothing 105 | Just cid -> lookupComponents (cid:cs') cs 106 | 107 | fromComponentIds :: StringTable PathComponentId -> [PathComponentId] -> FilePath 108 | fromComponentIds table = FilePath.joinPath . map (StringTable.index table) 109 | 110 | #if TESTS 111 | 112 | -- properties of a finite mapping... 113 | 114 | prop_lookup :: [(FilePath, TarEntryOffset)] -> FilePath -> Bool 115 | prop_lookup xs x = 116 | case (lookup (construct xs) x, Prelude.lookup x xs) of 117 | (Nothing, Nothing) -> True 118 | (Just (TarFileEntry offset), Just offset') -> offset == offset' 119 | _ -> False 120 | 121 | prop :: [(FilePath, TarEntryOffset)] -> Bool 122 | prop paths 123 | | not $ StringTable.prop pathbits = error "TarIndex: bad string table" 124 | | not $ IntTrie.prop intpaths = error "TarIndex: bad int trie" 125 | | not $ prop' = error "TarIndex: bad prop" 126 | | otherwise = True 127 | 128 | where 129 | index@(TarIndex pathTable _) = construct paths 130 | 131 | pathbits = concatMap (FilePath.splitDirectories . fst) paths 132 | intpaths = [ (cids, offset) 133 | | (path, offset) <- paths 134 | , let Just cids = toComponentIds pathTable path ] 135 | prop' = flip all paths $ \(file, offset) -> 136 | case lookup index file of 137 | Just (TarFileEntry offset') -> offset' == offset 138 | _ -> False 139 | 140 | 141 | example0 :: [(FilePath, Int)] 142 | example0 = 143 | [("foo-1.0/foo-1.0.cabal", 512) -- tar block 1 144 | ,("foo-1.0/LICENSE", 2048) -- tar block 4 145 | ,("foo-1.0/Data/Foo.hs", 4096)] -- tar block 8 146 | 147 | #endif 148 | -------------------------------------------------------------------------------- /Distribution/Server/Features/BuildReports/Backup.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE PatternGuards #-} 2 | module Distribution.Server.Features.BuildReports.Backup ( 3 | dumpBackup, 4 | restoreBackup, 5 | testRoundtrip, 6 | buildReportsToExport, 7 | packageReportsToExport 8 | ) where 9 | 10 | import Distribution.Server.Acid (update, query) 11 | import Distribution.Server.Features.BuildReports.BuildReport (BuildReport) 12 | import qualified Distribution.Server.Features.BuildReports.BuildReport as Report 13 | import Distribution.Server.Features.BuildReports.BuildReports (BuildReports(..), PkgBuildReports(..), BuildReportId(..), BuildLog(..)) 14 | import qualified Distribution.Server.Features.BuildReports.BuildReports as Reports 15 | import Distribution.Server.Features.BuildReports.State 16 | 17 | import Distribution.Server.Framework.BlobStorage (BlobStorage) 18 | import qualified Distribution.Server.Framework.BlobStorage as BlobStorage 19 | import Distribution.Server.Framework.BackupDump 20 | import Distribution.Server.Framework.BackupRestore 21 | import Distribution.Server.Util.Parse (unpackUTF8) 22 | 23 | import Distribution.Package 24 | import Distribution.Text (display, simpleParse) 25 | import Distribution.Version 26 | 27 | import Control.Monad (foldM) 28 | import Data.Map (Map) 29 | import qualified Data.Map as Map 30 | import Control.Monad.Trans (liftIO) 31 | import Control.Monad.State (get, put) 32 | import Data.Monoid (mempty) 33 | import System.FilePath (splitExtension) 34 | import Data.ByteString.Lazy.Char8 (ByteString) 35 | 36 | 37 | dumpBackup :: BlobStorage -> IO [BackupEntry] 38 | dumpBackup store = do 39 | buildReps <- query GetBuildReports 40 | exports <- readExportBlobs store (buildReportsToExport buildReps) 41 | return exports 42 | 43 | restoreBackup :: BlobStorage -> RestoreBackup 44 | restoreBackup storage = updateReports storage (Reports.emptyReports, Map.empty) 45 | 46 | testRoundtrip :: BlobStorage -> TestRoundtrip 47 | testRoundtrip store = testRoundtripByQuery' (query GetBuildReports) $ \buildReps -> do 48 | testBlobsExist store [blob | pkgBuildRep <- Map.elems (reportsIndex buildReps) 49 | , (_, Just (BuildLog blob)) <- Map.elems (reports pkgBuildRep)] 50 | 51 | -- when logs are encountered before their corresponding build reports 52 | type PartialLogs = Map (PackageId, BuildReportId) BuildLog 53 | 54 | updateReports :: BlobStorage -> (BuildReports, PartialLogs) -> RestoreBackup 55 | updateReports storage reports = RestoreBackup 56 | { restoreEntry = \(entry, bs) -> do 57 | res <- runImport reports $ case entry of 58 | ["package", pkgStr, reportItem] | Just pkgid <- simpleParse pkgStr -> case packageVersion pkgid of 59 | Version [] [] -> fail $ "Build report package id " ++ show pkgStr ++ " must specify a version" 60 | _ -> case splitExtension reportItem of 61 | (num, "txt") -> importReport pkgid num bs 62 | (num, "log") -> importLog storage pkgid num bs 63 | _ -> return () 64 | _ -> return () 65 | return $ fmap (updateReports storage) res 66 | , restoreFinalize = do 67 | let insertLog buildReps ((pkgid, reportId), buildLog) = case Reports.setBuildLog pkgid reportId (Just buildLog) buildReps of 68 | Just buildReps' -> Right buildReps' 69 | Nothing -> Left $ "Build log #" ++ display reportId ++ " exists for " ++ display pkgid ++ " but report itself does not" 70 | case foldM insertLog (fst reports) (Map.toList $ snd reports) of 71 | Right theReports -> return . Right $ finalizeReports theReports 72 | Left err -> return . Left $ err 73 | , restoreComplete = return () 74 | } 75 | 76 | finalizeReports :: BuildReports -> RestoreBackup 77 | finalizeReports reports = mempty 78 | { restoreComplete = update $ ReplaceBuildReports reports 79 | } 80 | 81 | importReport :: PackageId -> String -> ByteString -> Import (BuildReports, PartialLogs) () 82 | importReport pkgid repIdStr contents = do 83 | reportId <- parseText "report id" repIdStr 84 | case Report.parse (unpackUTF8 contents) of 85 | Left err -> fail err 86 | Right report -> do 87 | (buildReps, partialLogs) <- get 88 | let (mlog, partialLogs') = Map.updateLookupWithKey (\_ _ -> Nothing) (pkgid, reportId) partialLogs 89 | buildReps' = Reports.unsafeSetReport pkgid reportId (report, mlog) buildReps --doesn't check for duplicates 90 | put (buildReps', partialLogs') 91 | 92 | importLog :: BlobStorage -> PackageId -> String -> ByteString -> Import (BuildReports, PartialLogs) () 93 | importLog storage pkgid repIdStr contents = do 94 | reportId <- parseText "report id" repIdStr 95 | blobId <- liftIO $ BlobStorage.add storage contents 96 | let buildLog = BuildLog blobId 97 | (buildReps, logs) <- get 98 | case Reports.setBuildLog pkgid reportId (Just buildLog) buildReps of 99 | Nothing -> put (buildReps, Map.insert (pkgid, reportId) buildLog logs) 100 | Just buildReps' -> put (buildReps', logs) 101 | 102 | ------------------------------------------------------------------------------ 103 | buildReportsToExport :: BuildReports -> [ExportEntry] 104 | buildReportsToExport reports = concatMap (uncurry packageReportsToExport) (Map.toList $ Reports.reportsIndex reports) 105 | 106 | packageReportsToExport :: PackageId -> PkgBuildReports -> [ExportEntry] 107 | packageReportsToExport pkgid pkgReports = concatMap (uncurry $ reportToExport prefix) (Map.toList $ Reports.reports pkgReports) 108 | where prefix = ["package", display pkgid] 109 | 110 | reportToExport :: [FilePath] -> BuildReportId -> (BuildReport, Maybe BuildLog) -> [ExportEntry] 111 | reportToExport prefix reportId (report, mlog) = (getPath ".txt", Left . stringToBytes $ Report.show report) : 112 | case mlog of Nothing -> []; Just (BuildLog blobId) -> [blobToExport (getPath ".log") blobId] 113 | where 114 | getPath ext = prefix ++ [display reportId ++ ext] 115 | 116 | -------------------------------------------------------------------------------- /Distribution/Server/Features/BuildReports/State.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveDataTypeable, TypeFamilies, TemplateHaskell, 2 | FlexibleInstances, FlexibleContexts, MultiParamTypeClasses, 3 | TypeOperators, TypeSynonymInstances #-} 4 | module Distribution.Server.Features.BuildReports.State where 5 | 6 | import Distribution.Server.Features.BuildReports.BuildReports (BuildReportId, BuildLog, BuildReport, BuildReports, PkgBuildReports) 7 | import qualified Distribution.Server.Features.BuildReports.BuildReports as BuildReports 8 | 9 | import Distribution.Package 10 | 11 | import qualified Data.Serialize as Serialize 12 | import Control.Monad.Reader 13 | import qualified Control.Monad.State as State 14 | import Data.Acid (Query, Update, makeAcidic) 15 | import Data.SafeCopy (SafeCopy(..), contain) 16 | 17 | -- BuildReportId 18 | instance SafeCopy BuildReportId where 19 | putCopy = contain . Serialize.put 20 | getCopy = contain Serialize.get 21 | 22 | -- BuildLog 23 | instance SafeCopy BuildLog where 24 | putCopy = contain . Serialize.put 25 | getCopy = contain Serialize.get 26 | 27 | -- BuildReport 28 | instance SafeCopy BuildReport where 29 | putCopy = contain . Serialize.put 30 | getCopy = contain Serialize.get 31 | 32 | -- PkgBuildReports 33 | instance SafeCopy PkgBuildReports where 34 | putCopy = contain . Serialize.put 35 | getCopy = contain Serialize.get 36 | 37 | -- BuildReports 38 | instance SafeCopy BuildReports where 39 | putCopy = contain . Serialize.put 40 | getCopy = contain Serialize.get 41 | 42 | initialBuildReports :: BuildReports 43 | initialBuildReports = BuildReports.emptyReports 44 | 45 | -- and defined methods 46 | addReport :: PackageId -> (BuildReport, Maybe BuildLog) -> Update BuildReports BuildReportId 47 | addReport pkgid report = do 48 | buildReports <- State.get 49 | let (reports, reportId) = BuildReports.addReport pkgid report buildReports 50 | State.put reports 51 | return reportId 52 | 53 | setBuildLog :: PackageId -> BuildReportId -> Maybe BuildLog -> Update BuildReports Bool 54 | setBuildLog pkgid reportId buildLog = do 55 | buildReports <- State.get 56 | case BuildReports.setBuildLog pkgid reportId buildLog buildReports of 57 | Nothing -> return False 58 | Just reports -> State.put reports >> return True 59 | 60 | deleteReport :: PackageId -> BuildReportId -> Update BuildReports Bool --Maybe BuildReports 61 | deleteReport pkgid reportId = do 62 | buildReports <- State.get 63 | case BuildReports.deleteReport pkgid reportId buildReports of 64 | Nothing -> return False 65 | Just reports -> State.put reports >> return True 66 | 67 | lookupReport :: PackageId -> BuildReportId -> Query BuildReports (Maybe (BuildReport, Maybe BuildLog)) 68 | lookupReport pkgid reportId = asks (BuildReports.lookupReport pkgid reportId) 69 | 70 | lookupPackageReports :: PackageId -> Query BuildReports [(BuildReportId, (BuildReport, Maybe BuildLog))] 71 | lookupPackageReports pkgid = asks (BuildReports.lookupPackageReports pkgid) 72 | 73 | getBuildReports :: Query BuildReports BuildReports 74 | getBuildReports = ask 75 | 76 | replaceBuildReports :: BuildReports -> Update BuildReports () 77 | replaceBuildReports = State.put 78 | 79 | $(makeAcidic ''BuildReports ['addReport 80 | ,'setBuildLog 81 | ,'deleteReport 82 | ,'lookupReport 83 | ,'lookupPackageReports 84 | ,'getBuildReports 85 | ,'replaceBuildReports 86 | ]) 87 | 88 | -------------------------------------------------------------------------------- /Distribution/Server/Features/Distro/Backup.hs: -------------------------------------------------------------------------------- 1 | module Distribution.Server.Features.Distro.Backup ( 2 | dumpBackup, 3 | restoreBackup, 4 | 5 | distroUsersToExport, 6 | distroUsersToCSV, 7 | distrosToExport, 8 | distroToCSV 9 | ) where 10 | 11 | import Distribution.Server.Acid (update, query) 12 | import qualified Distribution.Server.Features.Distro.Distributions as Distros 13 | import Distribution.Server.Features.Distro.Distributions (DistroName, Distributions(..), DistroVersions(..), DistroPackageInfo(..)) 14 | import Distribution.Server.Features.Distro.State 15 | import Distribution.Server.Users.Group (UserList(..)) 16 | import Distribution.Server.Framework.BackupDump 17 | import Distribution.Server.Framework.BackupRestore 18 | 19 | import Distribution.Package 20 | import Distribution.Text 21 | import Data.Version 22 | import Text.CSV (CSV) 23 | 24 | import Data.ByteString.Lazy.Char8 (ByteString) 25 | import Control.Monad.State 26 | import qualified Data.Map as Map 27 | import Data.Map (Map) 28 | import qualified Data.IntSet as IntSet 29 | import Data.List (foldl') 30 | import Data.Monoid (mempty) 31 | import Control.Arrow (second) 32 | import System.FilePath (takeExtension) 33 | 34 | dumpBackup :: IO [BackupEntry] 35 | dumpBackup = do 36 | allDist <- query GetDistributions 37 | let distros = distDistros allDist 38 | versions = distVersions allDist 39 | return $ distroUsersToExport distros:distrosToExport distros versions 40 | 41 | restoreBackup :: RestoreBackup 42 | restoreBackup = updateDistros Distros.emptyDistributions Distros.emptyDistroVersions Map.empty 43 | 44 | updateDistros :: Distributions -> DistroVersions -> Map DistroName UserList -> RestoreBackup 45 | updateDistros distros versions maintainers = fix $ \restorer -> RestoreBackup 46 | { restoreEntry = \(path, bs) -> do 47 | case path of 48 | ["package", distro] | takeExtension distro == ".csv" -> do 49 | res <- runImport (distros, versions) (importDistro distro bs) 50 | case res of 51 | Right (distros', versions') -> return . Right $ 52 | updateDistros distros' versions' maintainers 53 | Left bad -> return (Left bad) 54 | ["maintainers.csv"] -> do 55 | res <- runImport maintainers (importMaintainers bs) 56 | case res of 57 | Right maintainers' -> return . Right $ 58 | updateDistros distros versions maintainers' 59 | Left bad -> return (Left bad) 60 | _ -> return . Right $ restorer 61 | , restoreFinalize = do 62 | let distros' = foldl' (\dists (name, group) -> Distros.modifyDistroMaintainers name (const group) dists) distros (Map.toList maintainers) 63 | return . Right $ finalizeDistros distros' versions 64 | , restoreComplete = return () 65 | } 66 | 67 | finalizeDistros :: Distributions -> DistroVersions -> RestoreBackup 68 | finalizeDistros distros versions = mempty 69 | { restoreComplete = update $ ReplaceDistributions distros versions 70 | } 71 | 72 | importMaintainers :: ByteString -> Import (Map DistroName UserList) () 73 | importMaintainers contents = importCSV "maintainers.csv" contents $ \csv -> do 74 | mapM_ fromRecord (drop 2 csv) 75 | where 76 | fromRecord (distroStr:idStr) = do 77 | distro <- parseText "distribution name" distroStr 78 | ids <- mapM (parseRead "user id") idStr 79 | modify $ Map.insert distro (UserList $ IntSet.fromList ids) 80 | fromRecord x = fail $ "Invalid distro maintainer record: " ++ show x 81 | 82 | importDistro :: String -> ByteString -> Import (Distributions, DistroVersions) () 83 | importDistro filename contents = importCSV filename contents $ \csv -> do 84 | let [[distroStr]] = take 1 $ drop 1 csv --no bounds checking.. 85 | distro <- parseText "distribution name" distroStr 86 | addDistribution distro 87 | mapM_ (fromRecord distro) (drop 3 csv) 88 | where 89 | fromRecord distro [packageStr, versionStr, uri] = do 90 | package <- parseText "package name" packageStr 91 | version <- parseText "version" versionStr 92 | addDistroPackage distro package $ DistroPackageInfo version uri 93 | fromRecord _ x = fail $ "Invalid distribution record in " ++ filename ++ ": " ++ show x 94 | 95 | addDistribution :: DistroName -> Import (Distributions, DistroVersions) () 96 | addDistribution distro = do 97 | (dists, versions) <- get 98 | case Distros.addDistro distro dists of 99 | Just dists' -> put (dists', versions) 100 | Nothing -> fail $ "Could not add distro: " ++ display distro 101 | 102 | addDistroPackage :: DistroName -> PackageName -> DistroPackageInfo -> Import (Distributions, DistroVersions) () 103 | addDistroPackage distro package info = 104 | modify $ \dists -> second (Distros.addPackage distro package info) dists 105 | 106 | -------------------------------------------------------------------------- 107 | distroUsersToExport :: Distributions -> BackupEntry 108 | distroUsersToExport distros = csvToBackup ["maintainers.csv"] (distroUsersToCSV assocUsers) 109 | where assocUsers = map (\(name, UserList ul) -> (name, IntSet.toList ul)) . Map.toList $ Distros.nameMap distros 110 | 111 | distroUsersToCSV :: [(DistroName, [Int])] -> CSV 112 | distroUsersToCSV users = [showVersion distrosCSVVer]:distrosCSVKey:map (\(name, ids) -> display name:map show ids) users 113 | where 114 | distrosCSVKey = ["distro", "maintainers"] 115 | distrosCSVVer = Version [0,1] ["unstable"] 116 | 117 | distrosToExport :: Distributions -> DistroVersions -> [BackupEntry] 118 | distrosToExport dists distInfo = map distroEntry (Distros.enumerate dists) 119 | where distroEntry distro = csvToBackup ["packages", display distro ++ ".csv"] (distroToCSV distro distInfo) 120 | 121 | distroToCSV :: DistroName -> DistroVersions -> CSV 122 | distroToCSV distro distInfo 123 | = let stats = Distros.distroStatus distro distInfo 124 | in ([showVersion distrosCSVVer]:) $ 125 | ([display distro]:) $ 126 | (distrosCSVKey:) $ 127 | flip map stats . uncurry $ 128 | \name (DistroPackageInfo version url) -> 129 | [display name, showVersion version, url] 130 | where 131 | distrosCSVKey = ["package", "version", "url"] 132 | distrosCSVVer = Version [0,1] ["unstable"] 133 | 134 | -------------------------------------------------------------------------------- /Distribution/Server/Features/Distro/Distributions.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE 2 | RecordWildCards 3 | #-} 4 | 5 | module Distribution.Server.Features.Distro.Distributions 6 | ( DistroName(..) 7 | , Distributions(..) 8 | , emptyDistributions 9 | , addDistro 10 | , removeDistro 11 | , updatePackageList 12 | , enumerate 13 | , isDistribution 14 | , DistroVersions(..) 15 | , emptyDistroVersions 16 | , DistroPackageInfo(..) 17 | , addPackage 18 | , dropPackage 19 | , removeDistroVersions 20 | , distroStatus 21 | , packageStatus 22 | , distroPackageStatus 23 | , getDistroMaintainers 24 | , modifyDistroMaintainers 25 | ) where 26 | 27 | import qualified Data.Map as Map 28 | import qualified Data.Set as Set 29 | 30 | import Distribution.Server.Features.Distro.Types 31 | import qualified Distribution.Server.Users.Group as Group 32 | import Distribution.Server.Users.Group (UserList) 33 | 34 | import Distribution.Package 35 | 36 | import Data.List (foldl') 37 | import Data.Maybe (fromJust, fromMaybe) 38 | 39 | emptyDistributions :: Distributions 40 | emptyDistributions = Distributions Map.empty 41 | 42 | emptyDistroVersions :: DistroVersions 43 | emptyDistroVersions = DistroVersions Map.empty Map.empty 44 | 45 | --- Distribution updating 46 | isDistribution :: DistroName -> Distributions -> Bool 47 | isDistribution distro distros 48 | = Map.member distro (nameMap distros) 49 | 50 | -- | Add a distribution. Returns 'Nothing' if the 51 | -- name is already in use. 52 | addDistro :: DistroName -> Distributions -> Maybe Distributions 53 | addDistro name distros 54 | | isDistribution name distros = Nothing 55 | | otherwise = Just . Distributions $ Map.insert name Group.empty (nameMap distros) 56 | 57 | 58 | -- | List all known distributions 59 | enumerate :: Distributions -> [DistroName] 60 | enumerate distros = Map.keys (nameMap distros) 61 | 62 | --- Queries 63 | 64 | -- | For a particular distribution, which packages do they have, and 65 | -- at which version. This function isn't very total. 66 | distroStatus :: DistroName -> DistroVersions -> [(PackageName, DistroPackageInfo)] 67 | distroStatus distro distros 68 | = let packageNames = maybe [] Set.toList (Map.lookup distro $ distroMap distros) 69 | f package = let infoMap = fromJust $ Map.lookup package (packageDistroMap distros) 70 | info = fromJust $ Map.lookup distro infoMap 71 | in (package, info) 72 | in map f packageNames 73 | 74 | -- | For a particular package, which distributions contain it and at which 75 | -- version. 76 | packageStatus :: PackageName -> DistroVersions -> [(DistroName, DistroPackageInfo)] 77 | packageStatus package dv = maybe [] Map.toList (Map.lookup package $ packageDistroMap dv) 78 | 79 | distroPackageStatus :: DistroName -> PackageName -> DistroVersions -> Maybe DistroPackageInfo 80 | distroPackageStatus distro package dv = Map.lookup distro =<< Map.lookup package (packageDistroMap dv) 81 | 82 | --- Removing 83 | 84 | -- | Remove a distirbution from the list of known distirbutions 85 | removeDistro :: DistroName -> Distributions -> Distributions 86 | removeDistro distro distros = distros { nameMap = Map.delete distro (nameMap distros) } 87 | 88 | -- | Drop all packages for a distribution. 89 | removeDistroVersions :: DistroName -> DistroVersions -> DistroVersions 90 | removeDistroVersions distro dv 91 | = let packageNames = maybe [] Set.toList (Map.lookup distro $ distroMap dv) 92 | in foldl' (flip $ dropPackage distro) dv packageNames 93 | 94 | --- Updating 95 | 96 | -- | Bulk update of all information for one specific distribution 97 | updatePackageList :: DistroName -> [(PackageName, DistroPackageInfo)] -> DistroVersions -> DistroVersions 98 | updatePackageList distro list dv = foldr (\(pn,dpi) -> addPackage distro pn dpi) (removeDistroVersions distro dv) list 99 | 100 | -- | Flag a package as no longer being distributed 101 | dropPackage :: DistroName -> PackageName -> DistroVersions -> DistroVersions 102 | dropPackage distro package dv@DistroVersions{..} 103 | = dv 104 | { packageDistroMap = Map.update pUpdate package packageDistroMap 105 | , distroMap = Map.update dUpdate distro distroMap 106 | } 107 | where pUpdate infoMap = 108 | case Map.delete distro infoMap of 109 | infoMap' 110 | -> if Map.null infoMap' 111 | then Nothing 112 | else Just infoMap' 113 | 114 | dUpdate packageNames = 115 | case Set.delete package packageNames of 116 | packageNames' 117 | -> if Set.null packageNames' 118 | then Nothing 119 | else Just packageNames' 120 | 121 | -- | Add a package for a distribution. If the distribution already 122 | -- had information for the specified package, that information is replaced. 123 | addPackage :: DistroName -> PackageName -> DistroPackageInfo 124 | -> DistroVersions -> DistroVersions 125 | addPackage distro package info dv@DistroVersions{..} 126 | = dv 127 | { packageDistroMap = Map.insertWith' 128 | (const $ Map.insert distro info) 129 | package 130 | (Map.singleton distro info) 131 | packageDistroMap 132 | 133 | , distroMap = Map.insertWith -- should be insertWith'? 134 | (const $ Set.insert package) 135 | distro 136 | (Set.singleton package) 137 | distroMap 138 | } 139 | 140 | getDistroMaintainers :: DistroName -> Distributions -> Maybe UserList 141 | getDistroMaintainers name = Map.lookup name . nameMap 142 | 143 | modifyDistroMaintainers :: DistroName -> (UserList -> UserList) -> Distributions -> Distributions 144 | modifyDistroMaintainers name func dists = dists {nameMap = Map.alter (Just . func . fromMaybe Group.empty) name (nameMap dists) } 145 | 146 | -------------------------------------------------------------------------------- /Distribution/Server/Features/Distro/State.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE 2 | DeriveDataTypeable 3 | , TemplateHaskell 4 | , RecordWildCards 5 | , TypeFamilies 6 | , FlexibleInstances 7 | , MultiParamTypeClasses 8 | , FlexibleContexts 9 | #-} 10 | 11 | module Distribution.Server.Features.Distro.State where 12 | 13 | import Distribution.Package (PackageName) 14 | 15 | import qualified Distribution.Server.Features.Distro.Distributions as Dist 16 | import Distribution.Server.Features.Distro.Distributions 17 | (DistroName, Distributions, DistroVersions, DistroPackageInfo) 18 | 19 | import Distribution.Server.Users.Group (UserList) 20 | import qualified Distribution.Server.Users.Group as Group 21 | import Distribution.Server.Users.Types (UserId) 22 | import Distribution.Server.Users.State () 23 | 24 | import Data.Acid (Query, Update, makeAcidic) 25 | import Data.SafeCopy (base, deriveSafeCopy) 26 | import Data.Typeable 27 | 28 | import Data.Maybe (fromMaybe) 29 | import Control.Monad (liftM) 30 | import Control.Monad.State.Class (get, put, modify) 31 | import Control.Monad.Reader.Class (ask, asks) 32 | 33 | data Distros = Distros { 34 | distDistros :: !Distributions, 35 | distVersions :: !DistroVersions 36 | } 37 | deriving (Eq, Typeable, Show) 38 | 39 | $(deriveSafeCopy 0 'base ''Distros) 40 | 41 | initialDistros :: Distros 42 | initialDistros = Distros Dist.emptyDistributions Dist.emptyDistroVersions 43 | 44 | addDistro :: DistroName -> Update Distros Bool 45 | addDistro name = do 46 | state <- get 47 | let distros = distDistros state 48 | case Dist.addDistro name distros of 49 | Nothing -> return False 50 | Just distros' -> put state{distDistros = distros'} >> return True 51 | 52 | -- DELETES a distribution. The name may then be re-used. 53 | -- You should also clean up the permissions DB as well. 54 | removeDistro :: DistroName -> Update Distros () 55 | removeDistro distro 56 | = modify $ \state@Distros{..} -> 57 | state { distDistros = Dist.removeDistro distro distDistros 58 | , distVersions = Dist.removeDistroVersions distro distVersions 59 | } 60 | 61 | enumerateDistros :: Query Distros [DistroName] 62 | enumerateDistros = asks $ Dist.enumerate . distDistros 63 | 64 | isDistribution :: DistroName -> Query Distros Bool 65 | isDistribution distro = asks $ Dist.isDistribution distro . distDistros 66 | 67 | getDistributions :: Query Distros Distros 68 | getDistributions = ask 69 | 70 | replaceDistributions :: Distributions -> DistroVersions -> Update Distros () 71 | replaceDistributions distributions distroVersions = put $ Distros distributions distroVersions 72 | 73 | addPackage :: DistroName -> PackageName -> DistroPackageInfo -> Update Distros () 74 | addPackage distro package info 75 | = modify $ \state -> 76 | state{ distVersions = Dist.addPackage distro package info $ distVersions state } 77 | 78 | dropPackage :: DistroName -> PackageName -> Update Distros () 79 | dropPackage distro package 80 | = modify $ \state -> 81 | state{ distVersions = Dist.dropPackage distro package $ distVersions state } 82 | 83 | distroStatus :: DistroName -> Query Distros [(PackageName, DistroPackageInfo)] 84 | distroStatus distro 85 | = asks $ Dist.distroStatus distro . distVersions 86 | 87 | putDistroPackageList :: DistroName -> [(PackageName, DistroPackageInfo)] -> Update Distros () 88 | putDistroPackageList distro list 89 | = modify $ \state-> 90 | state{ distVersions = Dist.updatePackageList distro list $ distVersions state } 91 | 92 | packageStatus :: PackageName -> Query Distros [(DistroName, DistroPackageInfo)] 93 | packageStatus package 94 | = asks $ Dist.packageStatus package . distVersions 95 | 96 | distroPackageStatus :: DistroName -> PackageName -> Query Distros (Maybe DistroPackageInfo) 97 | distroPackageStatus distro package = asks $ Dist.distroPackageStatus distro package . distVersions 98 | 99 | getDistroMaintainers :: DistroName -> Query Distros UserList 100 | getDistroMaintainers name = liftM (fromMaybe Group.empty . Dist.getDistroMaintainers name) (asks distDistros) 101 | 102 | modifyDistroMaintainers :: DistroName -> (UserList -> UserList) -> Update Distros () 103 | modifyDistroMaintainers name func = modify (\distros -> distros {distDistros = Dist.modifyDistroMaintainers name func (distDistros distros) }) 104 | 105 | addDistroMaintainer :: DistroName -> UserId -> Update Distros () 106 | addDistroMaintainer name uid = modifyDistroMaintainers name (Group.add uid) 107 | 108 | removeDistroMaintainer :: DistroName -> UserId -> Update Distros () 109 | removeDistroMaintainer name uid = modifyDistroMaintainers name (Group.remove uid) 110 | 111 | replaceDistroMaintainers :: DistroName -> UserList -> Update Distros () 112 | replaceDistroMaintainers name ulist = modifyDistroMaintainers name (const ulist) 113 | 114 | $(makeAcidic 115 | ''Distros 116 | [ -- update collection of distributions 117 | 'addDistro 118 | , 'removeDistro 119 | 120 | -- query collection of distributions 121 | , 'enumerateDistros 122 | , 'isDistribution 123 | 124 | -- update package versions in distros 125 | , 'addPackage 126 | , 'dropPackage 127 | 128 | -- query status of package versions 129 | , 'distroStatus 130 | , 'packageStatus 131 | , 'distroPackageStatus 132 | 133 | -- bulk update 134 | , 'putDistroPackageList 135 | 136 | -- import/export 137 | , 'getDistributions 138 | , 'replaceDistributions 139 | 140 | -- distro maintainers 141 | , 'getDistroMaintainers 142 | , 'replaceDistroMaintainers 143 | , 'addDistroMaintainer 144 | , 'removeDistroMaintainer 145 | ] 146 | ) 147 | -------------------------------------------------------------------------------- /Distribution/Server/Features/Distro/Types.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE 2 | DeriveDataTypeable 3 | , GeneralizedNewtypeDeriving 4 | , TemplateHaskell 5 | #-} 6 | 7 | 8 | 9 | module Distribution.Server.Features.Distro.Types where 10 | 11 | import Distribution.Server.Framework.Instances () 12 | import Distribution.Server.Users.State() 13 | import Distribution.Server.Users.Group (UserList) 14 | 15 | import qualified Data.Map as Map 16 | import qualified Data.Set as Set 17 | 18 | import qualified Distribution.Version as Version 19 | import Distribution.Package 20 | 21 | import Control.Applicative ((<$>)) 22 | 23 | import Distribution.Text (Text(..)) 24 | 25 | import qualified Distribution.Compat.ReadP as Parse 26 | import qualified Text.PrettyPrint as Disp 27 | import qualified Data.Char as Char 28 | 29 | import Data.SafeCopy (base, deriveSafeCopy) 30 | import Data.Typeable 31 | 32 | 33 | -- | Distribution names may contain letters, numbers and punctuation. 34 | newtype DistroName = DistroName String 35 | deriving (Eq, Ord, Read, Show, Typeable) 36 | 37 | instance Text DistroName where 38 | disp (DistroName name) = Disp.text name 39 | parse = DistroName <$> Parse.munch1 (\c -> Char.isAlphaNum c || c `elem` "-_()[]{}=$,;") 40 | 41 | 42 | -- | Listing of known distirbutions and their maintainers 43 | data Distributions = Distributions { 44 | nameMap :: !(Map.Map DistroName UserList) 45 | } 46 | deriving (Eq, Typeable, Show) 47 | 48 | -- | Listing of which distirbutions have which version of particular 49 | -- packages. 50 | data DistroVersions = DistroVersions { 51 | packageDistroMap :: !(Map.Map PackageName (Map.Map DistroName DistroPackageInfo)), 52 | distroMap :: !(Map.Map DistroName (Set.Set PackageName)) 53 | } deriving (Eq, Typeable, Show) 54 | 55 | data DistroPackageInfo 56 | = DistroPackageInfo 57 | { distroVersion :: Version.Version 58 | , distroUrl :: String 59 | } 60 | deriving (Eq, Typeable, Show) 61 | 62 | $(deriveSafeCopy 0 'base ''DistroName) 63 | $(deriveSafeCopy 0 'base ''Distributions) 64 | $(deriveSafeCopy 0 'base ''DistroVersions) 65 | $(deriveSafeCopy 0 'base ''DistroPackageInfo) 66 | -------------------------------------------------------------------------------- /Distribution/Server/Features/DownloadCount.hs: -------------------------------------------------------------------------------- 1 | module Distribution.Server.Features.DownloadCount ( 2 | DownloadFeature, 3 | downloadResource, 4 | DownloadResource(..), 5 | getDownloadHistogram, 6 | initDownloadFeature, 7 | perVersionDownloads, 8 | sortedPackages, 9 | ) where 10 | 11 | import Distribution.Server.Acid (query, update) 12 | import Distribution.Server.Framework 13 | import Distribution.Server.Features.Core 14 | 15 | import Distribution.Server.Packages.Downloads 16 | import Distribution.Server.Framework.BackupDump 17 | import Distribution.Server.Packages.Backup.Downloads 18 | import Distribution.Server.Util.Histogram 19 | import qualified Distribution.Server.Framework.Cache as Cache 20 | 21 | import Distribution.Package 22 | 23 | import Data.Time.Clock 24 | import Control.Arrow (second) 25 | import Control.Monad (forever) 26 | import Control.Concurrent.Chan 27 | import Control.Concurrent (forkIO) 28 | import Data.Function (fix) 29 | --import Data.List (sortBy) 30 | --import Data.Ord (comparing) 31 | import qualified Data.Map as Map 32 | import Control.Monad.Trans (MonadIO) 33 | 34 | data DownloadFeature = DownloadFeature { 35 | downloadResource :: DownloadResource, 36 | downloadStream :: Chan PackageId, 37 | downloadHistogram :: Cache.Cache (Histogram PackageName) 38 | } 39 | 40 | data DownloadResource = DownloadResource { 41 | topDownloads :: Resource 42 | } 43 | 44 | instance IsHackageFeature DownloadFeature where 45 | getFeatureInterface download = (emptyHackageFeature "download") { 46 | featureResources = map (\x -> x $ downloadResource download) [topDownloads] 47 | , featurePostInit = do countCache 48 | forkIO transferDownloads >> return () 49 | , featureDumpRestore = Just (dumpBackup, restoreBackup, testRoundtripByQuery (query GetDownloadCounts)) 50 | } 51 | where countCache = do 52 | dc <- query GetDownloadCounts 53 | let dmap = map (second packageDowns) (Map.toList $ downloadMap dc) 54 | Cache.putCache (downloadHistogram download) (constructHistogram dmap) 55 | transferDownloads = forever $ do 56 | pkg <- readChan (downloadStream download) 57 | time <- getCurrentTime 58 | (_, new) <- update $ RegisterDownload (utctDay time) pkg 1 59 | Cache.modifyCache (downloadHistogram download) 60 | (updateHistogram (packageName pkg) new) 61 | dumpBackup = do 62 | dc <- query GetDownloadCounts 63 | return [csvToBackup ["downloads.csv"] $ downloadsToCSV dc] 64 | restoreBackup = downloadsBackup 65 | 66 | initDownloadFeature :: ServerEnv -> CoreFeature -> IO DownloadFeature 67 | initDownloadFeature _ core = do 68 | downChan <- newChan 69 | downHist <- Cache.newCacheable emptyHistogram 70 | registerHook (tarballDownload core) $ writeChan downChan 71 | return DownloadFeature 72 | { downloadResource = fix $ \_ -> DownloadResource 73 | { topDownloads = resourceAt "/packages/top.:format" 74 | } 75 | , downloadStream = downChan 76 | , downloadHistogram = downHist 77 | } 78 | 79 | getDownloadHistogram :: DownloadFeature -> IO (Histogram PackageName) 80 | getDownloadHistogram = Cache.getCache . downloadHistogram 81 | 82 | --totalDownloadCount :: MonadIO m => m Int 83 | --totalDownloadCount = liftM totalDownloads $ query GetDownloadCounts 84 | 85 | -- sortedPackages and sortByDownloads both order packages by total downloads without exposing download data 86 | 87 | -- A lazy list of the top packages, which can be filtered, taken from, etc. 88 | -- Does not include packages with no downloads. 89 | sortedPackages :: DownloadFeature -> IO [(PackageName, Int)] 90 | sortedPackages downs = fmap topCounts $ Cache.getCache (downloadHistogram downs) 91 | 92 | {- 93 | -- Sorts a list of package-y items by their download count. 94 | -- Use sortedPackages to get an entire list. 95 | -- TODO: use the Histogram's sortByCounts for this 96 | sortByDownloads :: MonadIO m => (a -> PackageName) -> [a] -> m [(a, Int)] 97 | sortByDownloads nameFunc pkgs = query GetDownloadCounts >>= \counts -> do 98 | let modEntry pkg = (pkg, lookupPackageDowns (nameFunc pkg) downloadMap) 99 | return $ sortBy (comparing snd) $ map modEntry pkgs 100 | -} 101 | 102 | -- For at-a-glance download information. 103 | perVersionDownloads :: (MonadIO m, Package pkg) => pkg -> m (Int, Int) 104 | perVersionDownloads pkg = do 105 | info <- query $ GetDownloadInfo (packageName pkg) 106 | let (PackageDownloads total perVersion) = packageDownloads info 107 | return (total, Map.findWithDefault 0 (packageVersion pkg) perVersion) 108 | 109 | -------------------------------------------------------------------------------- /Distribution/Server/Features/HaskellPlatform.hs: -------------------------------------------------------------------------------- 1 | module Distribution.Server.Features.HaskellPlatform ( 2 | PlatformFeature, 3 | platformResource, 4 | PlatformResource(..), 5 | initPlatformFeature, 6 | platformVersions, 7 | platformPackageLatest, 8 | setPlatform, 9 | removePlatform 10 | ) where 11 | 12 | import Distribution.Server.Acid (query, update) 13 | import Distribution.Server.Framework 14 | import Distribution.Server.Features.Core 15 | import Distribution.Server.Packages.Platform 16 | import Data.Function 17 | 18 | import Distribution.Package 19 | import Distribution.Version 20 | import Distribution.Text 21 | 22 | import qualified Data.Map as Map 23 | import qualified Data.Set as Set 24 | import Control.Monad (liftM) 25 | import Control.Monad.Trans (MonadIO) 26 | 27 | -- Note: this can be generalized into dividing Hackage up into however many 28 | -- subsets of packages are desired. One could implement a Debian-esque system 29 | -- with this sort of feature. 30 | -- 31 | 32 | data PlatformFeature = PlatformFeature { 33 | platformResource :: PlatformResource 34 | } 35 | 36 | data PlatformResource = PlatformResource { 37 | platformPackage :: Resource, 38 | platformPackages :: Resource, 39 | platformPackageUri :: String -> PackageName -> String, 40 | platformPackagesUri :: String -> String 41 | } 42 | 43 | instance IsHackageFeature PlatformFeature where 44 | getFeatureInterface platform = (emptyHackageFeature "platform") { 45 | featureResources = map ($platformResource platform) [platformPackage, platformPackages] 46 | , featureDumpRestore = Nothing -- TODO 47 | } 48 | 49 | initPlatformFeature :: ServerEnv -> CoreFeature -> IO PlatformFeature 50 | initPlatformFeature _ _ = do 51 | return PlatformFeature 52 | { platformResource = fix $ \r -> PlatformResource 53 | { platformPackage = (resourceAt "/platform/package/:package.:format") { resourceGet = [], resourceDelete = [], resourcePut = [] } 54 | , platformPackages = (resourceAt "/platform/.:format") { resourceGet = [], resourcePost = [] } 55 | , platformPackageUri = \format pkgid -> renderResource (platformPackage r) [display pkgid, format] 56 | , platformPackagesUri = \format -> renderResource (platformPackages r) [format] 57 | -- and maybe "/platform/haskell-platform.cabal" 58 | } 59 | } 60 | 61 | ------------------------------------------ 62 | -- functionality: showing status for a single package, and for all packages, adding a package, deleting a package 63 | platformVersions :: MonadIO m => PackageName -> m [Version] 64 | platformVersions pkgname = liftM Set.toList $ query $ GetPlatformPackage pkgname 65 | 66 | platformPackageLatest :: MonadIO m => m [(PackageName, Version)] 67 | platformPackageLatest = liftM (Map.toList . Map.map Set.findMax . blessedPackages) $ query $ GetPlatformPackages 68 | 69 | setPlatform :: MonadIO m => PackageName -> [Version] -> m () 70 | setPlatform pkgname versions = update $ SetPlatformPackage pkgname (Set.fromList versions) 71 | 72 | removePlatform :: MonadIO m => PackageName -> m () 73 | removePlatform pkgname = update $ SetPlatformPackage pkgname Set.empty 74 | 75 | -------------------------------------------------------------------------------- /Distribution/Server/Features/LegacyRedirects.hs: -------------------------------------------------------------------------------- 1 | module Distribution.Server.Features.LegacyRedirects ( 2 | legacyRedirectsFeature 3 | ) where 4 | 5 | import Distribution.Server.Framework 6 | import Distribution.Server.Features.Upload 7 | 8 | import Distribution.Package 9 | ( PackageIdentifier(..), packageName, PackageId ) 10 | import Distribution.Text 11 | ( display, simpleParse ) 12 | 13 | import Data.Version ( Version (..) ) 14 | 15 | import qualified System.FilePath.Posix as Posix (joinPath, splitExtension) 16 | 17 | import Control.Applicative ( (<$>) ) 18 | import Control.Monad (msum, mzero) 19 | 20 | 21 | -- | A feature to provide redirection for URLs that existed in the first 22 | -- incarnation of the hackage server. 23 | -- 24 | legacyRedirectsFeature :: UploadFeature -> HackageFeature 25 | legacyRedirectsFeature upload = (emptyHackageFeature "legacy") { 26 | -- get rid of trailing resource and manually create a mapping? 27 | featureResources = [(resourceAt "/..") { resourceGet = [("", \_ -> serveLegacyGets)], resourcePost = [("", \_ -> serveLegacyPosts upload)] }] 28 | } 29 | 30 | -- | Support for the old URL scheme from the first version of hackage. 31 | -- 32 | 33 | -- | POST for package upload, particularly for cabal-install compatibility. 34 | -- 35 | -- "check" no longer exists; it's now "candidates", and probably 36 | -- provides too different functionality to redirect 37 | serveLegacyPosts :: UploadFeature -> ServerPart Response 38 | serveLegacyPosts upload = msum 39 | [ dir "packages" $ msum 40 | [ dir "upload" $ movedUpload 41 | --, postedMove "check" "/check" 42 | ] 43 | , dir "cgi-bin" $ dir "hackage-scripts" $ msum 44 | [ dir "protected" $ dir "upload" $ movedUpload 45 | --, postedMove "check" "/check" 46 | ] 47 | , dir "upload" movedUpload 48 | ] 49 | where 50 | 51 | -- We assume we don't need to serve a fancy HTML response 52 | movedUpload :: ServerPart Response 53 | movedUpload = nullDir >> do 54 | upResult <- runServerPartE (uploadPackage upload) 55 | ok $ toResponse $ unlines $ uploadWarnings upResult 56 | 57 | 58 | 59 | -- | GETs, both for cabal-install to use, and for links scattered throughout the web. 60 | -- 61 | -- method is already guarded against, but methodSP is a nicer combinator than nullDir. 62 | serveLegacyGets :: ServerPart Response 63 | serveLegacyGets = msum 64 | [ dir "packages" $ msum 65 | [ dir "archive" $ serveArchiveTree 66 | , simpleMove "hackage.html" "/" 67 | , simpleMove "00-index.tar.gz" "/packages/index.tar.gz" 68 | --also search.html, advancedsearch.html, accounts.html, and admin.html 69 | ] 70 | , dir "cgi-bin" $ dir "hackage-scripts" $ msum 71 | [ dir "package" $ path $ \packageId -> methodSP GET $ 72 | movedPermanently ("/package/" ++ display (packageId :: PackageId)) $ 73 | toResponse "" 74 | ] 75 | ] 76 | where 77 | -- HTTP 301 is suitable for permanently redirecting pages 78 | simpleMove from to = dir from $ methodSP GET $ movedPermanently to (toResponse "") 79 | 80 | -- Some of the old-style paths may contain a version number 81 | -- or the text 'latest'. We represent the path '$pkgName/latest' 82 | -- as a package id of '$pkgName' in the new url schemes. 83 | 84 | data VersionOrLatest 85 | = V Version 86 | | Latest 87 | 88 | instance FromReqURI VersionOrLatest where 89 | fromReqURI "latest" = Just Latest 90 | fromReqURI str = V <$> fromReqURI str 91 | 92 | volToVersion :: VersionOrLatest -> Version 93 | volToVersion Latest = Version [] [] 94 | volToVersion (V v) = v 95 | 96 | serveArchiveTree :: ServerPart Response 97 | serveArchiveTree = msum 98 | [ dir "pkg-list.html" $ methodSP GET $ movedPermanently "/packages/" (toResponse "") 99 | , dir "package" $ path $ \fileName -> methodSP GET $ 100 | case Posix.splitExtension fileName of 101 | (fileName', ".gz") -> case Posix.splitExtension fileName' of 102 | (packageStr, ".tar") -> case simpleParse packageStr of 103 | Just pkgid -> 104 | movedPermanently (packageTarball pkgid) $ toResponse "" 105 | _ -> mzero 106 | _ -> mzero 107 | _ -> mzero 108 | , dir "00-index.tar.gz" $ methodSP GET $ movedPermanently "/packages/index.tar.gz" (toResponse "") 109 | , path $ \name -> do 110 | msum 111 | [ path $ \version -> 112 | let pkgid = PackageIdentifier {pkgName = name, pkgVersion = volToVersion version} 113 | in msum 114 | [ let dirName = display pkgid ++ ".tar.gz" 115 | in dir dirName $ methodSP GET $ 116 | movedPermanently (packageTarball pkgid) (toResponse "") 117 | 118 | , let fileName = display name ++ ".cabal" 119 | in dir fileName $ methodSP GET $ 120 | movedPermanently (cabalPath pkgid) (toResponse "") 121 | 122 | , dir "doc" $ dir "html" $ remainingPath $ \paths -> 123 | let doc = Posix.joinPath paths 124 | in methodSP GET $ 125 | movedPermanently (docPath pkgid doc) (toResponse "") 126 | ] 127 | ] 128 | ] 129 | where 130 | packageTarball :: PackageId -> String 131 | packageTarball pkgid = "/package/" ++ display pkgid ++ "/" ++ display pkgid ++ ".tar.gz" 132 | 133 | docPath pkgid file = "/package/" ++ display pkgid ++ "/" ++ "doc/" ++ file 134 | 135 | cabalPath pkgid = "/package/" ++ display pkgid ++ "/" 136 | ++ display (packageName pkgid) ++ ".cabal" 137 | 138 | -------------------------------------------------------------------------------- /Distribution/Server/Features/PackageContents.hs: -------------------------------------------------------------------------------- 1 | module Distribution.Server.Features.PackageContents ( 2 | PackageContentsFeature, 3 | PackageContentsResource(..), 4 | initPackageContentsFeature 5 | ) where 6 | 7 | import Distribution.Server.Framework 8 | import Distribution.Server.Features.Check 9 | import Distribution.Server.Features.Core 10 | 11 | import Distribution.Server.Packages.Types 12 | import Distribution.Server.Framework.BlobStorage (BlobStorage) 13 | import Distribution.Server.Util.ChangeLog (lookupTarball, lookupChangeLog) 14 | import qualified Distribution.Server.Util.ServeTarball as TarIndex 15 | import Data.TarIndex (TarIndex) 16 | 17 | import Distribution.Text 18 | import Distribution.Package 19 | 20 | import Control.Monad.Trans 21 | 22 | 23 | -- FIXME: cache TarIndexes? 24 | 25 | data PackageContentsFeature = PackageContentsFeature { 26 | featureInterface :: HackageFeature, 27 | packageContentsResource :: PackageContentsResource 28 | } 29 | 30 | data PackageContentsResource = PackageContentsResource { 31 | packageContents :: Resource, 32 | packageContentsCandidate :: Resource, 33 | packageContentsChangeLog :: Resource, 34 | packageContentsCandidateChangeLog :: Resource, 35 | 36 | packageContentsChangeLogUri :: PackageId -> String, 37 | packageContentsCandidateChangeLogUri :: PackageId -> String 38 | } 39 | 40 | instance IsHackageFeature PackageContentsFeature where 41 | getFeatureInterface = featureInterface 42 | 43 | initPackageContentsFeature :: ServerEnv -> CoreFeature -> CheckFeature -> IO PackageContentsFeature 44 | initPackageContentsFeature env _ _ = do 45 | let store = serverBlobStore env 46 | resources = PackageContentsResource { 47 | packageContents = (resourceAt "/package/:package/src/..") { resourceGet = [("", serveContents store)] } 48 | , packageContentsCandidate = (resourceAt "/package/:package/candidate/src/..") { resourceGet = [("", serveCandidateContents store)] } 49 | , packageContentsChangeLog = (resourceAt "/package/:package/changelog") { resourceGet = [("changelog", serveChangeLog store)] } 50 | , packageContentsCandidateChangeLog = (resourceAt "/package/:package/candidate/changelog") { resourceGet = [("changelog", serveCandidateChangeLog store)] } 51 | 52 | , packageContentsChangeLogUri = \pkgid -> renderResource (packageContentsChangeLog resources) [display pkgid, display (packageName pkgid)] 53 | , packageContentsCandidateChangeLogUri = \pkgid -> renderResource (packageContentsCandidateChangeLog resources) [display pkgid, display (packageName pkgid)] 54 | } 55 | return PackageContentsFeature { 56 | featureInterface = (emptyHackageFeature "package-contents") { 57 | featureResources = map ($ resources) [packageContents, packageContentsCandidate, packageContentsChangeLog, packageContentsCandidateChangeLog] 58 | } 59 | , packageContentsResource = resources 60 | } 61 | 62 | 63 | --TODO: use something other than runServerPartE for nice html error pages 64 | 65 | withPackagePath', withCandidatePath' :: DynamicPath -> (PkgInfo -> ServerPartE a) -> ServerPartE a 66 | withPackagePath' dpath k = withPackagePath dpath $ \pkg _ -> k pkg 67 | withCandidatePath' dpath k = withCandidatePath dpath $ \_ pkg -> k (candPkgInfo pkg) 68 | 69 | -- result: changelog or not-found error 70 | serveChangeLog, serveCandidateChangeLog :: BlobStorage -> DynamicPath -> ServerPart Response 71 | serveChangeLog = serveChangeLog' withPackagePath' 72 | serveCandidateChangeLog = serveChangeLog' withCandidatePath' 73 | 74 | serveChangeLog' :: (DynamicPath -> ((PkgInfo -> ServerPartE Response) -> ServerPartE Response)) 75 | -> BlobStorage -> DynamicPath -> ServerPart Response 76 | serveChangeLog' with_pkg_path store dpath = runServerPartE $ with_pkg_path dpath $ \pkg -> do 77 | res <- liftIO $ lookupChangeLog store pkg 78 | case res of 79 | Left err -> errNotFound "Changelog not found" [MText err] 80 | Right (fp, offset, name) -> liftIO $ TarIndex.serveTarEntry fp offset name 81 | 82 | -- return: not-found error or tarball 83 | serveContents, serveCandidateContents :: BlobStorage -> DynamicPath -> ServerPart Response 84 | serveContents = serveContents' withPackagePath' 85 | serveCandidateContents = serveContents' withCandidatePath' 86 | 87 | serveContents' :: (DynamicPath -> ((PkgInfo -> ServerPartE Response) -> ServerPartE Response)) 88 | -> BlobStorage -> DynamicPath -> ServerPart Response 89 | serveContents' with_pkg_path store dpath = runServerPartE $ withContents $ \pkgid tarball index -> do 90 | -- if given a directory, the default page is index.html 91 | -- the default directory prefix is the package name itself (including the version) 92 | TarIndex.serveTarball ["index.html"] (display pkgid) tarball index 93 | where 94 | withContents :: (PackageId -> FilePath -> TarIndex -> ServerPartE Response) -> ServerPartE Response 95 | withContents func = with_pkg_path dpath $ \pkg -> 96 | case lookupTarball store pkg of 97 | Nothing -> fail "Could not serve package contents: no tarball exists." 98 | Just io -> liftIO io >>= \(fp, index) -> func (packageId pkg) fp index 99 | -------------------------------------------------------------------------------- /Distribution/Server/Features/StaticFiles.hs: -------------------------------------------------------------------------------- 1 | module Distribution.Server.Features.StaticFiles ( 2 | staticFilesFeature 3 | ) where 4 | 5 | import Distribution.Server.Framework 6 | 7 | -- | The feature to serve the static html files. 8 | -- 9 | -- Don't think this is going to be used that much, as it's not too modular, and 10 | -- must be last in order. Top-level handling seems more appropriate. 11 | staticFilesFeature :: HackageFeature 12 | staticFilesFeature = HackageFeature { 13 | 14 | featureName = "static files", 15 | 16 | serverPart = serveStaticFiles, 17 | 18 | -- There is no persistent state for this feature, 19 | -- so nothing needs to be backed up. 20 | dumpBackup = Nothing, 21 | restoreBackup = Nothing 22 | } 23 | 24 | serveStaticFiles :: ServerEnv -> ServerPart Response 25 | serveStaticFiles env = 26 | fileServe ["hackage.html"] (serverStaticDir env) 27 | -------------------------------------------------------------------------------- /Distribution/Server/Framework.hs: -------------------------------------------------------------------------------- 1 | -- | Re-export the common parts of the server framework. 2 | -- 3 | module Distribution.Server.Framework ( 4 | 5 | module Happstack.Server, 6 | module Distribution.Server.Framework.Auth, 7 | module Distribution.Server.Framework.Feature, 8 | module Distribution.Server.Framework.Types, 9 | module Distribution.Server.Framework.ResourceTypes, 10 | module Distribution.Server.Framework.Resource, 11 | module Distribution.Server.Framework.Hook, 12 | module Distribution.Server.Framework.Error, 13 | module Distribution.Server.Util.Happstack 14 | 15 | ) where 16 | 17 | import Happstack.Server 18 | import Distribution.Server.Framework.Auth 19 | import Distribution.Server.Framework.Feature 20 | import Distribution.Server.Framework.Types 21 | import Distribution.Server.Framework.ResourceTypes 22 | import Distribution.Server.Framework.Resource 23 | import Distribution.Server.Framework.Hook 24 | import Distribution.Server.Framework.Error 25 | import Distribution.Server.Util.Happstack 26 | -------------------------------------------------------------------------------- /Distribution/Server/Framework/AuthCrypt.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ForeignFunctionInterface #-} 2 | module Distribution.Server.Framework.AuthCrypt ( 3 | PasswdPlain(..), 4 | checkCryptAuthInfo, 5 | PasswdHash(..), 6 | newPasswdHash, 7 | checkBasicAuthInfo, 8 | BasicAuthInfo(..), 9 | DigestAuthInfo(..), 10 | QopInfo(..), 11 | checkDigestAuthInfo, 12 | ) where 13 | 14 | import Distribution.Server.Framework.AuthTypes 15 | import Distribution.Server.Users.Types (UserName(..)) 16 | 17 | import Data.Digest.Pure.MD5 (md5) 18 | import qualified Data.ByteString.Lazy.Char8 as BS.Lazy 19 | import Data.List (intercalate) 20 | 21 | import Foreign.C.String 22 | import System.IO.Unsafe (unsafePerformIO) 23 | 24 | import Control.Concurrent.MVar (MVar, newMVar, withMVar) 25 | 26 | -- Hashed passwords are stored in the format: 27 | -- 28 | -- @md5 (username ++ ":" ++ realm ++ ":" ++ password)@. 29 | -- 30 | -- This format enables us to use either the basic or digest 31 | -- HTTP authentication methods. 32 | 33 | -- | Create a new 'PasswdHash' suitable for safe permanent storage. 34 | -- 35 | newPasswdHash :: RealmName -> UserName -> PasswdPlain -> PasswdHash 36 | newPasswdHash (RealmName realmName) (UserName userName) (PasswdPlain passwd) = 37 | PasswdHash $ md5HexDigest [userName, realmName, passwd] 38 | 39 | ------------------ 40 | -- Crypt auth 41 | -- 42 | 43 | checkCryptAuthInfo :: HtPasswdHash -> PasswdPlain -> Bool 44 | checkCryptAuthInfo (HtPasswdHash hash) (PasswdPlain passwd) 45 | = crypt passwd hash == hash 46 | 47 | foreign import ccall unsafe "crypt" cCrypt :: CString-> CString -> CString 48 | 49 | crypt :: String -- ^ Payload 50 | -> String -- ^ Salt 51 | -> String -- ^ Hash 52 | crypt key seed = unsafePerformIO $ withMVar cryptMVar $ \_ -> do 53 | k <- newCAString key 54 | s <- newCAString seed 55 | peekCAString $ cCrypt k s 56 | 57 | cryptMVar :: MVar () 58 | cryptMVar = unsafePerformIO $ newMVar () 59 | {-# NOINLINE cryptMVar #-} 60 | 61 | ------------------ 62 | -- HTTP Basic auth 63 | -- 64 | 65 | data BasicAuthInfo = BasicAuthInfo { 66 | basicRealm :: RealmName, 67 | basicUsername :: UserName, 68 | basicPasswd :: PasswdPlain 69 | } 70 | 71 | checkBasicAuthInfo :: PasswdHash -> BasicAuthInfo -> Bool 72 | checkBasicAuthInfo hash (BasicAuthInfo realmName userName pass) = 73 | newPasswdHash realmName userName pass == hash 74 | 75 | ------------------ 76 | -- HTTP Digest auth 77 | -- 78 | 79 | data DigestAuthInfo = DigestAuthInfo { 80 | digestUsername :: UserName, 81 | digestNonce :: String, 82 | digestResponse :: String, 83 | digestURI :: String, 84 | digestRqMethod :: String, 85 | digestQoP :: QopInfo 86 | } 87 | deriving Show 88 | 89 | data QopInfo = QopNone 90 | | QopAuth { 91 | digestNonceCount :: String, 92 | digestClientNonce :: String 93 | } 94 | -- | QopAuthInt 95 | deriving Show 96 | 97 | -- See RFC 2617 http://www.ietf.org/rfc/rfc2617 98 | -- 99 | checkDigestAuthInfo :: PasswdHash -> DigestAuthInfo -> Bool 100 | checkDigestAuthInfo (PasswdHash passwdHash) 101 | (DigestAuthInfo _username nonce response uri method qopinfo) = 102 | hash3 == response 103 | where 104 | hash1 = passwdHash 105 | hash2 = md5HexDigest [method, uri] 106 | hash3 = case qopinfo of 107 | QopNone -> md5HexDigest [hash1, nonce, hash2] 108 | QopAuth nc cnonce -> md5HexDigest [hash1, nonce, nc, cnonce, "auth", hash2] 109 | 110 | ------------------ 111 | -- Utils 112 | -- 113 | 114 | md5HexDigest :: [String] -> String 115 | md5HexDigest = show . md5 . BS.Lazy.pack . intercalate ":" 116 | -------------------------------------------------------------------------------- /Distribution/Server/Framework/AuthTypes.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveDataTypeable, GeneralizedNewtypeDeriving, TemplateHaskell #-} 2 | module Distribution.Server.Framework.AuthTypes where 3 | 4 | import Data.Binary (Binary) 5 | import Data.SafeCopy (base, deriveSafeCopy) 6 | import Data.Typeable (Typeable) 7 | 8 | -- | A plain, unhashed password. Careful what you do with them. 9 | -- 10 | newtype PasswdPlain = PasswdPlain String 11 | deriving Eq 12 | 13 | -- | A password hash. It actually contains the hash of the username, passowrd 14 | -- and realm. 15 | -- 16 | -- Hashed passwords are stored in the format 17 | -- @md5 (username ++ ":" ++ realm ++ ":" ++ password)@. This format enables 18 | -- us to use either the basic or digest HTTP authentication methods. 19 | -- 20 | newtype PasswdHash = PasswdHash String 21 | deriving (Eq, Ord, Show, Binary, Typeable) 22 | 23 | -- | These are the *old* crypt format password hashes (salted DES: perl crypt). 24 | -- Not the same as the new hashes we store in 'PasswdHash'. 25 | newtype HtPasswdHash = HtPasswdHash String 26 | deriving (Eq, Show) 27 | 28 | newtype RealmName = RealmName String 29 | deriving (Show, Eq) 30 | 31 | $(deriveSafeCopy 0 'base ''PasswdPlain) 32 | $(deriveSafeCopy 0 'base ''PasswdHash) 33 | $(deriveSafeCopy 0 'base ''HtPasswdHash) -------------------------------------------------------------------------------- /Distribution/Server/Framework/BackupDump.hs: -------------------------------------------------------------------------------- 1 | {- 2 | Create a tarball with the structured defined by each individual feature. 3 | -} 4 | 5 | {-# LANGUAGE ScopedTypeVariables #-} 6 | 7 | module Distribution.Server.Framework.BackupDump ( 8 | exportTar, 9 | ExportEntry, 10 | readExportBlobs, 11 | csvToBackup, 12 | csvToExport, 13 | blobToExport, 14 | 15 | stringToBytes, 16 | 17 | testRoundtripByQuery, 18 | testRoundtripByQuery', 19 | testBlobsExist 20 | ) where 21 | 22 | import Distribution.Simple.Utils (toUTF8) 23 | import qualified Data.ByteString.Lazy.Char8 as BSL 24 | 25 | import Text.CSV hiding (csv) 26 | 27 | import Distribution.Server.Framework.BackupRestore (BackupEntry, TestRoundtrip) 28 | import qualified Distribution.Server.Framework.BlobStorage as Blob 29 | 30 | import Distribution.Server.Framework.BlobStorage 31 | 32 | --import Distribution.Text 33 | 34 | import qualified Data.ByteString.Lazy.Char8 as BS 35 | import Codec.Compression.GZip (compress) 36 | import qualified Codec.Archive.Tar as Tar 37 | import qualified Codec.Archive.Tar.Entry as Tar 38 | 39 | import Control.Monad (liftM, forM) 40 | import System.FilePath 41 | import System.Locale 42 | import System.IO.Unsafe (unsafeInterleaveIO) 43 | import Data.Maybe (catMaybes) 44 | import Data.Time 45 | 46 | exportTar :: [(String, IO [BackupEntry])] -> IO BS.ByteString 47 | exportTar = fmap (compress . Tar.write) . toEntries 48 | 49 | -- this is probably insufficiently lazy. use unsafeInterleaveIO to avoid loading /everything/ into memory 50 | toEntries :: [(String, IO [BackupEntry])] -> IO [Tar.Entry] 51 | toEntries featureMap = do 52 | baseDir <- mkBaseDir `fmap` getCurrentTime 53 | let exportEntries (name, ioEntries) = do 54 | entries <- ioEntries 55 | return $ flip map entries $ \(path, export) -> bsToEntry export (joinPath $ baseDir:name:path) 56 | unsafeInterleaveConcatMap exportEntries featureMap 57 | 58 | type ExportEntry = ([FilePath], Either BS.ByteString BlobId) 59 | 60 | readExportBlobs :: BlobStorage -> [ExportEntry] -> IO [BackupEntry] 61 | readExportBlobs storage entries = forM entries $ \(path, export) -> 62 | case export of 63 | Left bs -> return (path, bs) 64 | Right blobId -> do 65 | contents <- unsafeInterleaveIO $ Blob.fetch storage blobId 66 | return (path, contents) 67 | 68 | -- | Convert a ByteString to a tar entry 69 | bsToEntry :: BS.ByteString -> FilePath -> Tar.Entry 70 | bsToEntry chunk path = case Tar.toTarPath False path of 71 | Right tarPath -> Tar.fileEntry tarPath chunk 72 | Left err -> error $ "Error in export: " ++ err 73 | 74 | csvToBackup :: [String] -> CSV -> BackupEntry 75 | csvToBackup fpath csv = (fpath, BS.pack (printCSV csv)) 76 | 77 | csvToExport :: [String] -> CSV -> ExportEntry 78 | csvToExport fpath csv = (fpath, Left $ BS.pack (printCSV csv)) 79 | 80 | blobToExport :: [String] -> BlobId -> ExportEntry 81 | blobToExport fpath blob = (fpath, Right blob) 82 | 83 | mkBaseDir :: UTCTime -> FilePath 84 | mkBaseDir time = "export-" ++ formatTime defaultTimeLocale (iso8601DateFormat Nothing) time 85 | 86 | {- let's be crazy lazy 87 | 88 | The only non-pure operations we do are reading files 89 | from the blob-storage, which is already lazy IO. 90 | 91 | So we may as well not force the spine of the tar-ball 92 | before we need to. 93 | -} 94 | unsafeInterleaveConcatMap :: (a -> IO [b]) -> [a] -> IO [b] 95 | unsafeInterleaveConcatMap f = go 96 | where 97 | go [] = return [] 98 | go (x:xs) = do 99 | ys <- f x 100 | yss <- unsafeInterleaveIO $ go xs 101 | return (ys++yss) 102 | 103 | -- via UTF8 conversion. 104 | stringToBytes :: String -> BSL.ByteString 105 | stringToBytes = BSL.pack . toUTF8 106 | 107 | 108 | testRoundtripByQuery :: (Show a, Eq a) => IO a -> TestRoundtrip 109 | testRoundtripByQuery query = testRoundtripByQuery' query $ \_ -> return [] 110 | 111 | testRoundtripByQuery' :: (Show a, Eq a) => IO a -> (a -> IO [String]) -> TestRoundtrip 112 | testRoundtripByQuery' query k = do 113 | old <- query 114 | return $ do 115 | new <- query 116 | if old /= new 117 | then return ["Internal state mismatch:\n" ++ difference (show old) (show new)] 118 | else k new 119 | where 120 | difference old_str new_str 121 | -- = indent 2 old_str ++ "Versus:\n" ++ indent 2 new_str 122 | = "After " ++ show (length common) ++ " chars, in context:\n" ++ 123 | indent 2 (trunc_last 80 common) ++ "\nOld data was:\n" ++ 124 | indent 2 (trunc 80 old_str_tail) ++ "\nVersus new data:\n" ++ 125 | indent 2 (trunc 80 new_str_tail) 126 | where (common, old_str_tail, new_str_tail) = dropCommonPrefix [] old_str new_str 127 | 128 | indent n = unlines . map (replicate n ' ' ++) . lines 129 | 130 | trunc n xs | null zs = ys 131 | | otherwise = ys ++ "..." 132 | where (ys, zs) = splitAt n xs 133 | 134 | trunc_last n xs | null ys_rev = reverse zs_rev 135 | | otherwise = "..." ++ reverse zs_rev 136 | where (zs_rev, ys_rev) = splitAt n (reverse xs) 137 | 138 | dropCommonPrefix common (x:xs) (y:ys) | x == y = dropCommonPrefix (x:common) xs ys 139 | dropCommonPrefix common xs ys = (reverse common, xs, ys) 140 | 141 | testBlobsExist :: BlobStorage -> [Blob.BlobId] -> IO [String] 142 | testBlobsExist store blobs 143 | = liftM catMaybes $ forM blobs $ \blob -> do 144 | (Blob.fetch store blob >> return Nothing) `catch` 145 | \e -> return $ Just $ "Could not open blob " ++ show blob ++ ": " ++ show (e :: IOError) 146 | -------------------------------------------------------------------------------- /Distribution/Server/Framework/BlobStorage.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveDataTypeable, GeneralizedNewtypeDeriving, ScopedTypeVariables #-} 2 | ----------------------------------------------------------------------------- 3 | -- | 4 | -- Module : Distribution.Server.BlobStorage 5 | -- Copyright : Duncan Coutts 6 | -- 7 | -- Maintainer : Duncan Coutts 8 | -- Stability : alpha 9 | -- Portability : portable 10 | -- 11 | -- Persistent storage for blobs of data. 12 | -- 13 | module Distribution.Server.Framework.BlobStorage ( 14 | BlobStorage, 15 | BlobId, 16 | open, 17 | add, 18 | addWith, 19 | addFileWith, 20 | fetch, 21 | filepath, 22 | ) where 23 | 24 | import qualified Data.ByteString.Lazy as BS 25 | import Data.ByteString.Lazy (ByteString) 26 | import Data.Digest.Pure.MD5 (MD5Digest, md5) 27 | import Data.Typeable (Typeable) 28 | import Data.Serialize (Serialize) 29 | import System.FilePath (()) 30 | import Control.Exception (handle, throwIO, evaluate) 31 | import System.Directory 32 | import System.IO 33 | 34 | -- | An id for a blob. The content of the blob is stable. 35 | -- 36 | newtype BlobId = BlobId MD5Digest 37 | deriving (Eq, Ord, Serialize, Typeable) 38 | 39 | instance Show BlobId where show (BlobId digest) = show digest 40 | 41 | -- | A persistent blob storage area. Blobs can be added and retrieved but 42 | -- not removed or modified. 43 | -- 44 | newtype BlobStorage = BlobStorage FilePath -- ^ location of the store 45 | 46 | filepath :: BlobStorage -> BlobId -> FilePath 47 | filepath (BlobStorage storeDir) (BlobId hash) = storeDir show hash 48 | 49 | incomingDir :: BlobStorage -> FilePath 50 | incomingDir (BlobStorage storeDir) = storeDir "incoming" 51 | 52 | -- | Add a blob into the store. The result is a 'BlobId' that can be used 53 | -- later with 'fetch' to retrieve the blob content. 54 | -- 55 | -- * This operation is idempotent. That is, adding the same content again 56 | -- gives the same 'BlobId'. 57 | -- 58 | add :: BlobStorage -> ByteString -> IO BlobId 59 | add store content = 60 | withIncoming store content $ \_ blobId -> return (blobId, True) 61 | 62 | -- | Like 'add' but we get another chance to make another pass over the input 63 | -- 'ByteString'. 64 | -- 65 | -- What happens is that we stream the input into a temp file in an incoming 66 | -- area. Then we can make a second pass over it to do some validation or 67 | -- processing. If the validator decides to reject then we rollback and the 68 | -- blob is not entered into the store. If it accepts then the blob is added 69 | -- and the 'BlobId' is returned. 70 | -- 71 | addWith :: BlobStorage -> ByteString 72 | -> (ByteString -> IO (Either error result)) 73 | -> IO (Either error (result, BlobId)) 74 | addWith store content check = 75 | withIncoming store content $ \file blobId -> do 76 | content' <- BS.readFile file 77 | result <- check content' 78 | case result of 79 | Left err -> return (Left err, False) 80 | Right res -> return (Right (res, blobId), True) 81 | 82 | addFileWith :: BlobStorage -> FilePath 83 | -> (ByteString -> IO (Either error result)) 84 | -> IO (Either error (result, BlobId)) 85 | addFileWith store filePath check = 86 | withIncomingFile store filePath $ \file blobId -> do 87 | content' <- BS.readFile file 88 | result <- check content' 89 | case result of 90 | Left err -> return (Left err, False) 91 | Right res -> return (Right (res, blobId), True) 92 | 93 | hBlobId :: Handle -> IO BlobId 94 | hBlobId hnd = evaluate . BlobId . md5 =<< BS.hGetContents hnd 95 | 96 | fpBlobId :: FilePath -> IO BlobId 97 | fpBlobId file = 98 | do hnd <- openBinaryFile file ReadMode 99 | blobId <- hBlobId hnd 100 | hClose hnd 101 | return blobId 102 | 103 | withIncoming :: BlobStorage -> ByteString 104 | -> (FilePath -> BlobId -> IO (a, Bool)) 105 | -> IO a 106 | withIncoming store content action = do 107 | (file, hnd) <- openBinaryTempFile (incomingDir store) "new" 108 | handleExceptions file hnd $ do 109 | -- TODO: calculate the md5 and write to the temp file in one pass: 110 | BS.hPut hnd content 111 | hSeek hnd AbsoluteSeek 0 112 | blobId <- hBlobId hnd 113 | hClose hnd 114 | withIncoming' store file blobId action 115 | where 116 | handleExceptions tmpFile tmpHandle = 117 | handle $ \err -> do 118 | hClose tmpHandle 119 | removeFile tmpFile 120 | throwIO (err :: IOError) 121 | 122 | withIncomingFile :: BlobStorage 123 | -> FilePath 124 | -> (FilePath -> BlobId -> IO (a, Bool)) 125 | -> IO a 126 | withIncomingFile store file action = 127 | do blobId <- fpBlobId file 128 | withIncoming' store file blobId action 129 | 130 | withIncoming' :: BlobStorage -> FilePath -> BlobId -> (FilePath -> BlobId -> IO (a, Bool)) -> IO a 131 | withIncoming' store file blobId action = do 132 | -- open a new Handle since the old one is closed by hGetContents 133 | (res, commit) <- action file blobId 134 | if commit 135 | --TODO: if the target already exists then there is no need to overwrite 136 | -- it since it will have the same content. Checking and then renaming 137 | -- would give a race condition but that's ok since they have the same 138 | -- content. 139 | then renameFile file (filepath store blobId) 140 | else removeFile file 141 | return res 142 | 143 | 144 | -- | Retrieve a blob from the store given its 'BlobId'. 145 | -- 146 | -- * The content corresponding to a given 'BlobId' never changes. 147 | -- 148 | -- * The blob must exist in the store or it is an error. 149 | -- 150 | fetch :: BlobStorage -> BlobId -> IO ByteString 151 | fetch store blobid = BS.readFile (filepath store blobid) 152 | 153 | -- | Opens an existing or new blob storage area. 154 | -- 155 | open :: FilePath -> IO BlobStorage 156 | open storeDir = do 157 | createDirectoryIfMissing False storeDir 158 | let store = BlobStorage storeDir 159 | createDirectoryIfMissing False (incomingDir store) 160 | return store 161 | -------------------------------------------------------------------------------- /Distribution/Server/Framework/Cache.hs: -------------------------------------------------------------------------------- 1 | module Distribution.Server.Framework.Cache ( 2 | Cache(..), 3 | newCache, 4 | newCacheable, 5 | getCache, 6 | putCache, 7 | modifyCache, 8 | respondCache 9 | ) where 10 | 11 | import qualified Distribution.Server.Util.AsyncVar as AsyncVar 12 | import Distribution.Server.Util.AsyncVar (AsyncVar) 13 | 14 | import Happstack.Server 15 | 16 | import Control.Monad.Trans (MonadIO(liftIO)) 17 | import Control.DeepSeq 18 | 19 | -- | A general-purpose in-memory cache. 20 | newtype Cache a = Cache { cacheState :: AsyncVar a } 21 | 22 | newCache :: a -> (a -> b) -> IO (Cache a) 23 | newCache state forceFunc = Cache `fmap` AsyncVar.new (\a -> forceFunc a `seq` ()) state 24 | 25 | -- How necessary is it to use deepseq to fully evaluate the cache? Too low-level? 26 | newCacheable :: NFData a => a -> IO (Cache a) 27 | newCacheable emptyValue = newCache emptyValue rnf 28 | 29 | getCache :: MonadIO m => Cache a -> m a 30 | getCache (Cache avar) = liftIO $ AsyncVar.read avar 31 | 32 | putCache :: MonadIO m => Cache a -> a -> m () 33 | putCache (Cache avar) state = liftIO $ AsyncVar.write avar state 34 | 35 | modifyCache :: MonadIO m => Cache a -> (a -> a) -> m () 36 | modifyCache (Cache avar) func = liftIO $ AsyncVar.modify avar func 37 | 38 | ----------------------------------------------------------------------- 39 | -- usually b = DynamicPath. This saves on code nodes (elsewhere) and imports (here) 40 | respondCache :: ToMessage r => Cache a -> (a -> r) -> b -> ServerPart Response 41 | respondCache cache func _ = return . toResponse . func =<< getCache cache 42 | 43 | -------------------------------------------------------------------------------- /Distribution/Server/Framework/Error.hs: -------------------------------------------------------------------------------- 1 | -- | Error handling style for the hackage server. 2 | -- 3 | -- The point is to be able to abort and return appropriate HTTP errors, plus 4 | -- human readable messages. 5 | -- 6 | -- We use a standard error monad / exception style so that we can hide some of 7 | -- the error checking plumbing. 8 | -- 9 | -- We use a custom error type that enables us to render the error in an 10 | -- appropriate way, ie themed html or plain text, depending on the context. 11 | -- 12 | module Distribution.Server.Framework.Error ( 13 | 14 | -- * Server error monad 15 | ServerPartE, 16 | 17 | -- * Generating errors 18 | MessageSpan(..), 19 | errBadRequest, 20 | errForbidden, 21 | errNotFound, 22 | errInternalError, 23 | throwError, 24 | 25 | -- * Handling errors 26 | ErrorResponse(..), 27 | runServerPartE, 28 | handleErrorResponse, 29 | messageToText, 30 | ) where 31 | 32 | import Happstack.Server 33 | import Control.Monad.Error 34 | 35 | -- | A derivative of the 'ServerPartT' monad with an extra error monad layer. 36 | -- 37 | -- So we can use the standard 'MonadError' methods like 'throwError'. 38 | -- 39 | type ServerPartE a = ServerPartT (ErrorT ErrorResponse IO) a 40 | 41 | -- | A type for generic error reporting that should be sufficient for 42 | -- most purposes. 43 | -- 44 | data ErrorResponse = ErrorResponse { 45 | errorCode :: Int, 46 | errorTitle :: String, 47 | errorDetail :: [MessageSpan] 48 | } 49 | 50 | -- | A message possibly including hypertext links. 51 | -- 52 | -- The point is to be able to render error messages either as text or as html. 53 | -- 54 | data MessageSpan = MLink String String | MText String 55 | 56 | -- | Format a message as simple text. 57 | -- 58 | -- For html or other formats you'll have to write your own function! 59 | -- 60 | messageToText :: [MessageSpan] -> String 61 | messageToText [] = "" 62 | messageToText (MLink x _:xs) = x ++ messageToText xs 63 | messageToText (MText x :xs) = x ++ messageToText xs 64 | 65 | -- We don't want to use these methods directly anyway. 66 | instance Error ErrorResponse where 67 | noMsg = ErrorResponse 500 "Internal server error" [] 68 | strMsg str = ErrorResponse 500 "Internal server error" [MText str] 69 | 70 | 71 | errBadRequest :: String -> [MessageSpan] -> ServerPartE a 72 | errBadRequest title message = throwError (ErrorResponse 400 title message) 73 | 74 | -- note: errUnauthorized is deliberately not provided because exceptions thrown 75 | -- in this way bypass the FilterMonad stuff and so setHeaderM etc are ignored 76 | -- but setHeaderM are usually needed for responding to auth errors. 77 | 78 | errForbidden :: String -> [MessageSpan] -> ServerPartE a 79 | errForbidden title message = throwError (ErrorResponse 403 title message) 80 | 81 | errNotFound :: String -> [MessageSpan] -> ServerPartE a 82 | errNotFound title message = throwError (ErrorResponse 404 title message) 83 | 84 | errInternalError :: [MessageSpan] -> ServerPartE a 85 | errInternalError message = throwError (ErrorResponse 500 title message) 86 | where 87 | title = "Internal server error" 88 | 89 | -- | Run a 'ServerPartE', including a top-level fallback error handler. 90 | -- 91 | -- Any 'ErrorResponse' exceptions are turned into a simple error response with 92 | -- a \"text/plain\" formated body. 93 | -- 94 | -- To use a nicer custom formatted error response, use 'handleErrorResponse'. 95 | -- 96 | runServerPartE :: ServerPartE a -> ServerPart a 97 | runServerPartE = mapServerPartT' (spUnwrapErrorT fallbackHandler) 98 | where 99 | fallbackHandler :: ErrorResponse -> ServerPart a 100 | fallbackHandler err = finishWith (result (errorCode err) message) 101 | where 102 | message = errorTitle err ++ ": " ++ messageToText (errorDetail err) 103 | 104 | handleErrorResponse :: (ErrorResponse -> ServerPartE Response) 105 | -> ServerPartE a -> ServerPartE a 106 | handleErrorResponse handler action = 107 | catchError action (\errResp -> handler errResp >>= finishWith) 108 | -------------------------------------------------------------------------------- /Distribution/Server/Framework/Feature.hs: -------------------------------------------------------------------------------- 1 | -- | This module defines a plugin interface for hackage features. 2 | -- 3 | module Distribution.Server.Framework.Feature where 4 | 5 | import Distribution.Server.Framework.BackupRestore (RestoreBackup, BackupEntry, TestRoundtrip) 6 | import Distribution.Server.Framework.Resource (Resource) 7 | 8 | -- | We compose the overall hackage server featureset from a bunch of these 9 | -- features. The intention is to make the hackage server reasonably modular 10 | -- by allowing distinct features to be designed independently. 11 | -- 12 | -- Features can hold their own canonical state and caches, and can provide a 13 | -- set of resources. 14 | -- 15 | -- Features that hold canonical state must support dump/restore by defining 16 | -- 'featureDumpRestore' appropriately. 17 | -- 18 | data HackageFeature = HackageFeature { 19 | featureName :: String, 20 | featureResources :: [Resource], 21 | 22 | featurePostInit :: IO (), 23 | 24 | featureDumpRestore :: Maybe (IO [BackupEntry], RestoreBackup, TestRoundtrip) 25 | } 26 | 27 | -- | A feature with no state and no resources, just a name. 28 | -- 29 | -- Define your new feature by extending this one, e.g. 30 | -- 31 | -- > myHackageFeature = emptyHackageFeature "wizzo" { 32 | -- > featureResources = [wizzo] 33 | -- > } 34 | -- 35 | emptyHackageFeature :: String -> HackageFeature 36 | emptyHackageFeature name = HackageFeature { 37 | featureName = name, 38 | featureResources = [], 39 | 40 | featurePostInit = return (), 41 | 42 | featureDumpRestore = Nothing 43 | } 44 | 45 | class IsHackageFeature feature where 46 | getFeatureInterface :: feature -> HackageFeature 47 | -------------------------------------------------------------------------------- /Distribution/Server/Framework/Hook.hs: -------------------------------------------------------------------------------- 1 | module Distribution.Server.Framework.Hook ( 2 | Hook, 3 | Filter, 4 | newHook, 5 | registerHook, 6 | registerHooks, 7 | 8 | runHooks, 9 | runHook, 10 | runHook', 11 | runHook'', 12 | 13 | runFilters, 14 | runFilter, 15 | runFilter', 16 | runFilter'' 17 | ) where 18 | 19 | import Data.IORef 20 | import Control.Monad.Trans (MonadIO, liftIO) 21 | 22 | -- | A list of hooks, usually IO actions. 23 | -- 24 | -- A local IORef is nicer than MVar for this task, although TVar might be even nicer 25 | data Hook a = Hook (IORef [a]) 26 | 27 | -- another name for Hook, used when the result is important 28 | type Filter a = Hook a 29 | 30 | newHook :: IO (Hook a) 31 | newHook = fmap Hook $ newIORef [] 32 | 33 | -- registers a hook to be run *before* all of the previously registered hooks. 34 | -- is this the best strategy? relying on ordering rules of any kind can introduce 35 | -- nasty bugs. 36 | registerHook :: Hook a -> a -> IO () 37 | registerHook (Hook list) hook = modifyIORef list (hook:) 38 | 39 | registerHooks :: Hook a -> [a] -> IO () 40 | registerHooks hlist hooks = mapM_ (registerHook hlist) hooks 41 | 42 | -- TODO: catch errors 43 | runHooks :: MonadIO m => Hook a -> (a -> IO b) -> m () 44 | runHooks (Hook vlist) func = liftIO $ readIORef vlist >>= mapM_ func 45 | 46 | runFilters :: MonadIO m => Filter a -> (a -> IO b) -> m [b] 47 | runFilters (Hook vlist) func = liftIO $ readIORef vlist >>= mapM func 48 | 49 | -- boilerplate code, maybe replaceable by insane typeclass magic 50 | runHook :: MonadIO m => Hook (IO ()) -> m () 51 | runHook list = runHooks list id 52 | 53 | runHook' :: MonadIO m => Hook (a -> IO ()) -> a -> m () 54 | runHook' list a = runHooks list (\f -> f a) 55 | 56 | runHook'' :: MonadIO m => Hook (a -> b -> IO ()) -> a -> b -> m () 57 | runHook'' list a b = runHooks list (\f -> f a b) 58 | 59 | runFilter :: MonadIO m => Filter (IO a) -> m [a] 60 | runFilter list = runFilters list id 61 | 62 | runFilter' :: MonadIO m => Filter (a -> IO b) -> a -> m [b] 63 | runFilter' list a = runFilters list (\f -> f a) 64 | 65 | runFilter'' :: MonadIO m => Filter (a -> b -> IO c) -> a -> b -> m [c] 66 | runFilter'' list a b = runFilters list (\f -> f a b) 67 | 68 | -------------------------------------------------------------------------------- /Distribution/Server/Framework/Instances.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP, DeriveDataTypeable, StandaloneDeriving, FlexibleContexts #-} 2 | 3 | -- | 'Typeable', 'Binary', 'Serialize', and 'NFData' instances for various 4 | -- types from Cabal, and other standard libraries. 5 | -- 6 | -- Major version changes may break this module. 7 | -- 8 | 9 | module Distribution.Server.Framework.Instances () where 10 | 11 | import Distribution.Text 12 | 13 | import Distribution.Package (PackageIdentifier(..), PackageName(..)) 14 | import Distribution.PackageDescription (GenericPackageDescription(..)) 15 | import Distribution.Version (Version(..), VersionRange(..)) 16 | 17 | import Data.Typeable 18 | import Data.Time.Clock (UTCTime(..)) 19 | import Data.Time.Calendar (Day(..)) 20 | 21 | import Control.DeepSeq 22 | 23 | import qualified Data.Serialize as Serialize 24 | import Data.Serialize (Serialize) 25 | import Data.SafeCopy (SafeCopy(getCopy, putCopy), contain) 26 | 27 | import Happstack.Server 28 | 29 | import qualified Data.ByteString.Lazy.Char8 as BS 30 | import Data.ByteString.Lazy.Char8 (ByteString) 31 | import Data.Maybe (fromJust) 32 | 33 | deriving instance Typeable PackageIdentifier 34 | deriving instance Typeable GenericPackageDescription 35 | deriving instance Typeable PackageName 36 | deriving instance Typeable VersionRange 37 | 38 | instance Serialize PackageIdentifier where 39 | put = Serialize.put . show 40 | get = fmap read Serialize.get 41 | 42 | instance SafeCopy PackageIdentifier where 43 | putCopy = contain . Serialize.put . show 44 | getCopy = contain $ fmap read Serialize.get 45 | 46 | instance SafeCopy PackageName where 47 | getCopy = contain textGet 48 | putCopy = contain . textPut 49 | 50 | instance SafeCopy Version where 51 | getCopy = contain textGet 52 | putCopy = contain . textPut 53 | 54 | instance SafeCopy VersionRange where 55 | getCopy = contain textGet 56 | putCopy = contain . textPut 57 | 58 | instance FromReqURI PackageIdentifier where 59 | fromReqURI = simpleParse 60 | 61 | instance FromReqURI PackageName where 62 | fromReqURI = simpleParse 63 | 64 | instance FromReqURI Version where 65 | fromReqURI = simpleParse 66 | 67 | -- These assume that the text representations 68 | -- for Cabal types will be stable over time 69 | textGet :: Text a => Serialize.Get a 70 | textGet = (fromJust . simpleParse) `fmap` Serialize.get 71 | 72 | textPut :: Text a => a -> Serialize.Put 73 | textPut = Serialize.put . display 74 | 75 | instance Serialize UTCTime where 76 | put time = do 77 | Serialize.put (toModifiedJulianDay $ utctDay time) 78 | Serialize.put (toRational $ utctDayTime time) 79 | get = do 80 | day <- Serialize.get 81 | secs <- Serialize.get 82 | return (UTCTime (ModifiedJulianDay day) (fromRational secs)) 83 | 84 | -- rough versions of RNF for these 85 | instance NFData ByteString where 86 | rnf bs = BS.length bs `seq` () 87 | 88 | instance NFData Response where 89 | rnf res@(Response{}) = rnf $ rsBody res 90 | rnf _ = () 91 | 92 | instance NFData PackageName where 93 | rnf (PackageName pkg) = rnf pkg 94 | 95 | instance NFData PackageIdentifier where 96 | rnf (PackageIdentifier name version) = rnf name `seq` rnf version 97 | 98 | #if !MIN_VERSION_deepseq(1,3,0) 99 | instance NFData Version where 100 | rnf (Version cont tags) = rnf cont `seq` rnf tags 101 | 102 | instance NFData Day where 103 | rnf (ModifiedJulianDay day) = rnf day 104 | 105 | instance NFData UTCTime where 106 | rnf time = rnf (utctDay time) `seq` rnf (toRational $ utctDayTime time) 107 | #endif 108 | 109 | -------------------------------------------------------------------------------- /Distribution/Server/Framework/ResourceTypes.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GeneralizedNewtypeDeriving, DeriveDataTypeable, StandaloneDeriving #-} 2 | {-# OPTIONS_GHC -fno-warn-orphans #-} 3 | ----------------------------------------------------------------------------- 4 | -- | 5 | -- Module : Distribution.Server.Framework.ResourceTypes 6 | -- Copyright : (c) David Himmelstrup 2008 7 | -- Duncan Coutts 2008 8 | -- License : BSD-like 9 | -- 10 | -- Maintainer : duncan@haskell.org 11 | -- Stability : provisional 12 | -- Portability : portable 13 | -- 14 | -- Types for various kinds of resources we serve, xml, package tarballs etc. 15 | ----------------------------------------------------------------------------- 16 | module Distribution.Server.Framework.ResourceTypes where 17 | 18 | import Distribution.Server.Framework.BlobStorage 19 | ( BlobId ) 20 | 21 | import Happstack.Server 22 | ( ToMessage(..), Response(..), RsFlags(..), Length(NoContentLength), nullRsFlags, mkHeaders 23 | , noContentLength ) 24 | 25 | import qualified Data.ByteString.Char8 as BS 26 | import qualified Data.ByteString.Lazy.Char8 as BS.Lazy 27 | import Text.RSS (RSS) 28 | import qualified Text.RSS as RSS (rssToXML, showXML) 29 | import qualified Text.XHtml.Strict as XHtml (Html, renderHtml) 30 | import qualified Text.JSON as JSON (JSValue, encode) 31 | import Data.Time.Clock (UTCTime) 32 | import qualified Data.Time.Format as Time (formatTime) 33 | import System.Locale (defaultTimeLocale) 34 | import Text.CSV (printCSV, CSV) 35 | 36 | data IndexTarball = IndexTarball BS.Lazy.ByteString 37 | 38 | instance ToMessage IndexTarball where 39 | toContentType _ = BS.pack "application/gzip" 40 | toMessage (IndexTarball bs) = bs 41 | 42 | 43 | data PackageTarball = PackageTarball BS.Lazy.ByteString BlobId UTCTime 44 | 45 | instance ToMessage PackageTarball where 46 | toResponse (PackageTarball bs blobid time) = mkResponse bs 47 | [ ("Content-Type", "application/gzip") 48 | , ("Content-MD5", show blobid) 49 | , ("ETag", '"' : show blobid ++ ['"']) 50 | , ("Last-modified", formatTime time) 51 | ] 52 | 53 | data DocTarball = DocTarball BS.Lazy.ByteString BlobId 54 | 55 | instance ToMessage DocTarball where 56 | toResponse (DocTarball bs blobid) = mkResponse bs 57 | [ ("Content-Type", "application/gzip") 58 | , ("Content-MD5", show blobid) 59 | , ("ETag", '"' : show blobid ++ ['"']) 60 | ] 61 | 62 | formatTime :: UTCTime -> String 63 | formatTime = Time.formatTime defaultTimeLocale rfc822DateFormat 64 | where 65 | -- HACK! we're using UTC but http requires GMT 66 | -- hopefully it's ok to just say it's GMT 67 | rfc822DateFormat = "%a, %d %b %Y %H:%M:%S GMT" 68 | 69 | newtype OpenSearchXml = OpenSearchXml BS.Lazy.ByteString 70 | 71 | instance ToMessage OpenSearchXml where 72 | toContentType _ = BS.pack "application/opensearchdescription+xml" 73 | toMessage (OpenSearchXml bs) = bs 74 | 75 | newtype SuggestJson = SuggestJson JSON.JSValue 76 | instance ToMessage SuggestJson where 77 | toContentType _ = BS.pack "application/x-suggestions+json" 78 | toMessage (SuggestJson val) = BS.Lazy.pack $ JSON.encode val 79 | 80 | newtype CabalFile = CabalFile BS.Lazy.ByteString 81 | 82 | instance ToMessage CabalFile where 83 | toContentType _ = BS.pack "text/plain" 84 | toMessage (CabalFile bs) = bs 85 | 86 | newtype BuildLog = BuildLog BS.Lazy.ByteString 87 | 88 | instance ToMessage BuildLog where 89 | toContentType _ = BS.pack "text/plain" 90 | toMessage (BuildLog bs) = bs 91 | 92 | instance ToMessage RSS where 93 | toContentType _ = BS.pack "application/rss+xml" 94 | toMessage = BS.Lazy.pack . RSS.showXML . RSS.rssToXML 95 | 96 | newtype XHtml = XHtml XHtml.Html 97 | 98 | instance ToMessage XHtml where 99 | toContentType _ = BS.pack "application/xhtml+xml" 100 | toMessage (XHtml xhtml) = BS.Lazy.pack (XHtml.renderHtml xhtml) 101 | 102 | -- Like XHtml, but don't bother calculating length 103 | newtype LongXHtml = LongXHtml XHtml.Html 104 | 105 | instance ToMessage LongXHtml where 106 | toResponse (LongXHtml xhtml) = noContentLength $ mkResponse 107 | (BS.Lazy.pack (XHtml.renderHtml xhtml)) 108 | [("Content-Type", "application/xhtml+xml")] 109 | 110 | newtype ExportTarball = ExportTarball BS.Lazy.ByteString 111 | 112 | instance ToMessage ExportTarball where 113 | toResponse (ExportTarball bs) 114 | = noContentLength $ mkResponse bs 115 | [("Content-Type", "application/gzip")] 116 | 117 | newtype CSVFile = CSVFile CSV 118 | 119 | instance ToMessage CSVFile where 120 | toContentType _ = BS.pack "text/csv" 121 | toMessage (CSVFile csv) = BS.Lazy.pack (printCSV csv) 122 | 123 | mkResponse :: BS.Lazy.ByteString -> [(String, String)] -> Response 124 | mkResponse bs headers = Response { 125 | rsCode = 200, 126 | rsHeaders = mkHeaders headers, 127 | rsFlags = nullRsFlags, 128 | rsBody = bs, 129 | rsValidator = Nothing 130 | } 131 | 132 | mkResponseLen :: BS.Lazy.ByteString -> Int -> [(String, String)] -> Response 133 | mkResponseLen bs len headers = Response { 134 | rsCode = 200, 135 | rsHeaders = mkHeaders (("Content-Length", show len) : headers), 136 | rsFlags = nullRsFlags { rsfLength = NoContentLength }, 137 | rsBody = bs, 138 | rsValidator = Nothing 139 | } 140 | 141 | -------------------------------------------------------------------------------- /Distribution/Server/Framework/Types.hs: -------------------------------------------------------------------------------- 1 | module Distribution.Server.Framework.Types where 2 | 3 | import Distribution.Server.Framework.BlobStorage (BlobStorage) 4 | 5 | import Happstack.Server 6 | import qualified Network.URI as URI 7 | 8 | -- | The internal server environment as used by 'HackageFeature's. 9 | -- 10 | -- It contains various bits of static information (and handles of 11 | -- server-global objects) that are needed by the implementations of 12 | -- some 'HackageFeature's. 13 | -- 14 | data ServerEnv = ServerEnv { 15 | 16 | -- | The location of the server's static files 17 | serverStaticDir :: FilePath, 18 | 19 | -- | The location of the server's state directory. This is where the 20 | -- server's persistent state is kept, e.g. using ACID state. 21 | serverStateDir :: FilePath, 22 | 23 | -- | The blob store is a specialised provider of persistent state for 24 | -- larger relatively-static blobs of data (e.g. uploaded tarballs). 25 | serverBlobStore :: BlobStorage, 26 | 27 | -- | The temporary directory the server has been configured to use. 28 | -- Use it for temp files such as when validating uploads. 29 | serverTmpDir :: FilePath, 30 | 31 | -- | The base URI of the server, just the hostname (and perhaps port). 32 | -- Use this if you need to construct absolute URIs pointing to the 33 | -- current server (e.g. as required in RSS feeds). 34 | serverHostURI :: URI.URIAuth 35 | } 36 | 37 | type DynamicPath = [(String, String)] 38 | 39 | type ServerResponse = DynamicPath -> ServerPart Response 40 | 41 | -------------------------------------------------------------------------------- /Distribution/Server/LegacyImport/HtPasswdDb.hs: -------------------------------------------------------------------------------- 1 | -- | Parsing @.htpasswd@ files 2 | -- 3 | module Distribution.Server.LegacyImport.HtPasswdDb ( 4 | HtPasswdDb, 5 | parse, 6 | ) where 7 | 8 | import Distribution.Server.Users.Types (UserName(..)) 9 | import Distribution.Server.Framework.AuthTypes (HtPasswdHash(..)) 10 | 11 | type HtPasswdDb = [(UserName, HtPasswdHash)] 12 | 13 | parse :: String -> Either String HtPasswdDb 14 | parse = accum 0 [] . map parseLine . lines 15 | where 16 | accum _ pairs [] = Right pairs 17 | accum n pairs (Just pair:rest) = accum (n+1) (pair:pairs) rest 18 | accum n _ (Nothing :_ ) = Left errmsg 19 | where errmsg = "parse error in htpasswd file on line " ++ show (n :: Int) 20 | 21 | parseLine :: String -> Maybe (UserName, HtPasswdHash) 22 | parseLine line = case break (==':') line of 23 | (user@(_:_), ':' : hash) -> Just (UserName user, HtPasswdHash hash) 24 | _ -> Nothing 25 | -------------------------------------------------------------------------------- /Distribution/Server/LegacyImport/UploadLog.hs: -------------------------------------------------------------------------------- 1 | ----------------------------------------------------------------------------- 2 | -- | 3 | -- Module : Distribution.Server.UploadLog 4 | -- Copyright : (c) Ross Paterson 2007 5 | -- Duncan Coutts 2008 6 | -- License : BSD-like 7 | -- 8 | -- Maintainer : duncan@haskell.org 9 | -- Stability : provisional 10 | -- Portability : portable 11 | -- 12 | -- Support for reading the upload log of the old hackage server. 13 | ----------------------------------------------------------------------------- 14 | module Distribution.Server.LegacyImport.UploadLog ( 15 | Entry(..), 16 | read, 17 | group, 18 | ) where 19 | 20 | import Distribution.Server.Users.Types 21 | ( UserName ) 22 | 23 | import Distribution.Package 24 | ( PackageIdentifier(..)) 25 | import Distribution.Text 26 | ( Text(..), simpleParse ) 27 | import Distribution.ParseUtils ( parsePackageNameQ ) 28 | import qualified Distribution.Compat.ReadP as Parse 29 | import qualified Text.PrettyPrint as Disp 30 | import Text.PrettyPrint 31 | ( (<+>) ) 32 | import Distribution.Simple.Utils 33 | ( comparing, equating ) 34 | 35 | import Data.Time.Clock 36 | ( UTCTime ) 37 | import Data.Time.LocalTime 38 | ( ZonedTime(..), TimeZone(..), zonedTimeToUTC ) 39 | import Data.Time.Format 40 | ( readsTime, formatTime ) 41 | import System.Locale 42 | ( defaultTimeLocale ) 43 | import Data.List 44 | ( sortBy, groupBy ) 45 | 46 | import Prelude hiding (read) 47 | 48 | data Entry = Entry UTCTime UserName PackageIdentifier 49 | deriving (Eq, Ord, Show) 50 | 51 | instance Text Entry where 52 | disp (Entry time user pkgid) = 53 | Disp.text (formatTime defaultTimeLocale "%c" time) 54 | <+> disp user <+> disp pkgid 55 | parse = do 56 | time <- Parse.readS_to_P (readsTime defaultTimeLocale "%c") 57 | Parse.skipSpaces 58 | user <- parse 59 | Parse.skipSpaces 60 | pkg <- parsePackageNameQ 61 | Parse.skipSpaces 62 | ver <- parse 63 | let pkgid = PackageIdentifier pkg ver 64 | return (Entry (zonedTimeToUTC (fixupTimeZone time)) user pkgid) 65 | 66 | -- | Returns a list of log entries, however some packages have been uploaded 67 | -- more than once, so each entry is paired with any older entries for the same 68 | -- package. 69 | -- 70 | read :: String -> Either String [Entry] 71 | read = check [] . map parseLine . lines 72 | where 73 | check es' [] = Right es' 74 | check es' (Right e:es) = check (e:es') es 75 | check _ (Left err:_) = Left err 76 | parseLine line = maybe (Left err) Right (simpleParse line) 77 | where err = "Failed to parse log line:\n" ++ show line 78 | 79 | group :: [Entry] -> [(Entry, [Entry])] 80 | group = 81 | map ((\(p:ps) -> (p, ps)) 82 | . sortBy (comparing packageTime)) 83 | . groupBy (equating packageId) 84 | . sortBy (comparing packageId) 85 | where 86 | packageId (Entry _ _ pkgid) = pkgid 87 | packageTime (Entry t _ _) = t 88 | 89 | -- | The time lib doesn't know the time offsets of standard time zones so we 90 | -- have to do it ourselves for a couple zones we're interested in. Sigh. 91 | fixupTimeZone :: ZonedTime -> ZonedTime 92 | fixupTimeZone zt@ZonedTime { zonedTimeZone = tz } 93 | | timeZoneName tz == "PST" = zt { zonedTimeZone = pst } 94 | | timeZoneName tz == "PDT" = zt { zonedTimeZone = pdt } 95 | | otherwise = zt 96 | where 97 | pst = TimeZone (-8 * 60) False "PST" 98 | pdt = TimeZone (-7 * 60) True "PDT" 99 | -------------------------------------------------------------------------------- /Distribution/Server/Packages/Backup/Downloads.hs: -------------------------------------------------------------------------------- 1 | module Distribution.Server.Packages.Backup.Downloads ( 2 | downloadsBackup, 3 | downloadsToCSV, 4 | downloadsToRecord 5 | ) where 6 | 7 | import Distribution.Server.Acid (update) 8 | import Distribution.Server.Packages.Downloads 9 | import Distribution.Server.Framework.BackupRestore 10 | 11 | import Distribution.Package 12 | import Distribution.Text (display) 13 | import Distribution.Version 14 | 15 | import Text.CSV (CSV, Record) 16 | import qualified Data.Map as Map 17 | import Control.Monad 18 | import Control.Monad.State (modify) 19 | import Data.Function (fix) 20 | import Data.ByteString.Lazy.Char8 (ByteString) 21 | import Data.Time.Calendar 22 | 23 | downloadsBackup :: RestoreBackup 24 | downloadsBackup = updateDownloads emptyDownloadCounts 25 | 26 | updateDownloads :: DownloadCounts -> RestoreBackup 27 | updateDownloads dcs = fix $ \r -> RestoreBackup 28 | { restoreEntry = \(entry, bs) -> do 29 | res <- runImport dcs $ case entry of 30 | ["downloads.csv"] -> importDownloads bs 31 | _ -> return () 32 | return $ fmap updateDownloads res 33 | , restoreFinalize = return . Right $ r 34 | , restoreComplete = update $ ReplacePackageDownloads dcs 35 | } 36 | 37 | importDownloads :: ByteString -> Import DownloadCounts () 38 | importDownloads contents = importCSV "downloads.csv" contents $ \csv -> 39 | mapM_ fromRecord csv 40 | where 41 | fromRecord [dayField, packageNameField, packageVerField, countField] = do 42 | day <- liftM ModifiedJulianDay $ parseRead "day" dayField 43 | pkgname <- parseText "package name" packageNameField 44 | pkgver <- parseText "package version" packageVerField 45 | count <- parseRead "day download count" countField 46 | modify $ incrementCounts day pkgname pkgver count 47 | fromRecord x = fail $ "Invalid tags record: " ++ show x 48 | 49 | ------------------------------------------------------------------------------ 50 | downloadsToCSV :: DownloadCounts -> CSV 51 | downloadsToCSV dcs 52 | = [ downloadsToRecord day pkg_name pkg_ver count 53 | | (pkg_name, di) <- Map.toList (downloadMap dcs) 54 | , (day, pds) <- Map.toList (dayDownloads di) 55 | , (pkg_ver, count) <- Map.toList (versionDownloads pds) 56 | ] 57 | 58 | downloadsToRecord :: Day -> PackageName -> Version -> Int -> Record -- [String] 59 | downloadsToRecord day pkg_name pkg_ver count = [show (toModifiedJulianDay day), display pkg_name, display pkg_ver, show count] 60 | -------------------------------------------------------------------------------- /Distribution/Server/Packages/Backup/Tags.hs: -------------------------------------------------------------------------------- 1 | module Distribution.Server.Packages.Backup.Tags ( 2 | tagsBackup, 3 | tagsToCSV, 4 | tagsToRecord 5 | ) where 6 | 7 | import Distribution.Server.Acid (update) 8 | import Distribution.Server.Packages.Tag 9 | import Distribution.Server.Framework.BackupRestore 10 | 11 | 12 | import Distribution.Package 13 | import Distribution.Text (display) 14 | 15 | import Text.CSV (CSV, Record) 16 | import qualified Data.Map as Map 17 | -- import Data.Set (Set) 18 | import qualified Data.Set as Set 19 | -- import Control.Monad.IO.Class 20 | import Control.Monad.State (modify) 21 | import Data.Function (fix) 22 | import Data.ByteString.Lazy.Char8 (ByteString) 23 | 24 | tagsBackup :: RestoreBackup 25 | tagsBackup = updateTags emptyPackageTags 26 | 27 | updateTags :: PackageTags -> RestoreBackup 28 | updateTags tags = fix $ \r -> RestoreBackup 29 | { restoreEntry = \(entry, bs) -> do 30 | res <- runImport tags $ case entry of 31 | ["tags.csv"] -> importTags bs 32 | _ -> return () 33 | return $ fmap updateTags res 34 | , restoreFinalize = return . Right $ r 35 | , restoreComplete = update $ ReplacePackageTags tags 36 | } 37 | 38 | importTags :: ByteString -> Import PackageTags () 39 | importTags contents = importCSV "tags.csv" contents $ \csv -> 40 | mapM_ fromRecord csv 41 | where 42 | fromRecord (packageField:tagFields) | not (null tagFields) = do 43 | pkgname <- parseText "package name" packageField 44 | -- TODO: the filtering ignores empty tags, currently necessary because 45 | -- of the lack of category for uu-parsinglib. need to fix the 46 | -- actual data at some point instead, as well as improve the 47 | -- validation applied to the CSV 48 | tags <- mapM (parseText "tag") (filter (not . null) tagFields) 49 | modify $ setTags pkgname (Set.fromList tags) 50 | fromRecord x = fail $ "Invalid tags record: " ++ show x 51 | 52 | ------------------------------------------------------------------------------ 53 | tagsToCSV :: PackageTags -> CSV 54 | tagsToCSV = map (\(p, t) -> tagsToRecord p $ Set.toList t) 55 | . Map.toList . packageTags 56 | 57 | tagsToRecord :: PackageName -> [Tag] -> Record -- [String] 58 | tagsToRecord pkgname tags = display pkgname:map display tags 59 | 60 | -------------------------------------------------------------------------------- /Distribution/Server/Packages/Downloads.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveDataTypeable, TypeFamilies, TemplateHaskell, 2 | FlexibleInstances, FlexibleContexts, MultiParamTypeClasses, 3 | TypeOperators, TypeSynonymInstances #-} 4 | 5 | module Distribution.Server.Packages.Downloads where 6 | 7 | import Distribution.Server.Framework.Instances () 8 | import Distribution.Package 9 | import Distribution.Version 10 | 11 | import Data.Acid 12 | import Data.SafeCopy (base, deriveSafeCopy) 13 | import Data.Time.Calendar 14 | import Data.Typeable (Typeable) 15 | import Data.Map (Map) 16 | import Data.Maybe (fromMaybe) 17 | import qualified Data.Map as Map 18 | import Control.Monad.State (put, get) 19 | import Control.Monad.Reader (ask, asks) 20 | import Control.DeepSeq 21 | 22 | ----------------------------------------- 23 | -- DownloadCounts is where the download records are converted to an historical 24 | -- format at leisure 25 | data DownloadCounts = DownloadCounts { 26 | totalDownloads :: Int, 27 | downloadMap :: Map PackageName DownloadInfo 28 | } deriving (Eq, Show, Typeable) 29 | emptyDownloadCounts :: DownloadCounts 30 | emptyDownloadCounts = DownloadCounts 0 Map.empty 31 | 32 | data DownloadInfo = DownloadInfo { 33 | monthDownloads :: Map (Int, Int) PackageDownloads, 34 | dayDownloads :: Map Day PackageDownloads, 35 | packageDownloads :: PackageDownloads 36 | } deriving (Eq, Show, Typeable) 37 | emptyDownloadInfo :: DownloadInfo 38 | emptyDownloadInfo = DownloadInfo Map.empty Map.empty emptyPackageDownloads 39 | 40 | data PackageDownloads = PackageDownloads { 41 | allDownloads :: Int, 42 | versionDownloads :: Map Version Int 43 | } deriving (Eq, Show, Typeable) 44 | emptyPackageDownloads :: PackageDownloads 45 | emptyPackageDownloads = PackageDownloads 0 Map.empty 46 | 47 | packageDowns :: DownloadInfo -> Int 48 | packageDowns = allDownloads . packageDownloads 49 | 50 | lookupPackageDowns :: DownloadCounts -> PackageName -> Int 51 | lookupPackageDowns dcs pkgname = maybe 0 packageDowns $ Map.lookup pkgname (downloadMap dcs) 52 | 53 | incrementCounts :: Day -> PackageName -> Version -> Int -> DownloadCounts -> DownloadCounts 54 | incrementCounts day pkgname version count (DownloadCounts total perPackage) = 55 | DownloadCounts 56 | (total + count) 57 | (adjustFrom (incrementInfo day version count) pkgname emptyDownloadInfo perPackage) 58 | 59 | incrementInfo :: Day -> Version -> Int -> DownloadInfo -> DownloadInfo 60 | incrementInfo day version count (DownloadInfo perMonth perDay total) = 61 | DownloadInfo 62 | (adjustFrom (incrementPackage version count) (fromIntegral year, month) emptyPackageDownloads perMonth) 63 | (adjustFrom (incrementPackage version count) day emptyPackageDownloads perDay) 64 | (incrementPackage version count total) 65 | where 66 | (year, month, _) = toGregorian day 67 | 68 | incrementPackage :: Version -> Int -> PackageDownloads -> PackageDownloads 69 | incrementPackage version count (PackageDownloads total perVersion) = 70 | PackageDownloads (total + count) (adjustFrom (+count) version 0 perVersion) 71 | 72 | adjustFrom :: Ord k => (a -> a) -> k -> a -> Map k a -> Map k a 73 | adjustFrom func key value = Map.alter (Just . func . fromMaybe value) key 74 | 75 | ---- 76 | replacePackageDownloads :: DownloadCounts -> Update DownloadCounts () 77 | replacePackageDownloads = put 78 | 79 | registerDownload :: Day -> PackageId -> Int -> Update DownloadCounts (Int, Int) 80 | registerDownload day pkgid count = do 81 | dc <- get 82 | let pkgname = packageName pkgid 83 | dc' = incrementCounts day pkgname (packageVersion pkgid) count dc 84 | put dc' 85 | return (lookupPackageDowns dc pkgname, lookupPackageDowns dc' pkgname) 86 | 87 | getDownloadCounts :: Query DownloadCounts DownloadCounts 88 | getDownloadCounts = ask 89 | 90 | getDownloadInfo :: PackageName -> Query DownloadCounts DownloadInfo 91 | getDownloadInfo pkgname = asks (Map.findWithDefault emptyDownloadInfo pkgname . downloadMap) 92 | 93 | -------------------------------------------------------------------------------- 94 | 95 | $(deriveSafeCopy 0 'base ''DownloadCounts) 96 | $(deriveSafeCopy 0 'base ''DownloadInfo) 97 | $(deriveSafeCopy 0 'base ''PackageDownloads) 98 | 99 | instance NFData PackageDownloads where 100 | rnf (PackageDownloads a b) = rnf a `seq` rnf b 101 | instance NFData DownloadInfo where 102 | rnf (DownloadInfo a b c) = rnf a `seq` rnf b `seq` rnf c 103 | instance NFData DownloadCounts where 104 | rnf (DownloadCounts a b) = rnf a `seq` rnf b 105 | 106 | initialDownloadCounts :: DownloadCounts 107 | initialDownloadCounts = emptyDownloadCounts 108 | 109 | $(makeAcidic ''DownloadCounts ['replacePackageDownloads 110 | ,'registerDownload 111 | ,'getDownloadCounts 112 | ,'getDownloadInfo 113 | ]) 114 | 115 | -------------------------------------------------------------------------------- /Distribution/Server/Packages/Index.hs: -------------------------------------------------------------------------------- 1 | ----------------------------------------------------------------------------- 2 | -- | 3 | -- Module : Distribution.Server.Packages.Index 4 | -- Copyright : (c) Duncan Coutts 2008 5 | -- License : BSD-like 6 | -- 7 | -- Maintainer : duncan@haskell.org 8 | -- Stability : provisional 9 | -- Portability : portable 10 | -- 11 | -- Create the package index. 12 | -- 13 | ----------------------------------------------------------------------------- 14 | module Distribution.Server.Packages.Index ( 15 | write, 16 | ) where 17 | 18 | import qualified Codec.Archive.Tar.Entry as Tar 19 | import qualified Distribution.Server.Util.Index as PackageIndex 20 | 21 | import Distribution.Server.Packages.Types 22 | ( CabalFileText(..), PkgInfo(..) ) 23 | import qualified Distribution.Server.Users.Users as Users 24 | ( Users, idToName ) 25 | 26 | import Distribution.Text 27 | ( display ) 28 | import Distribution.Server.Packages.PackageIndex (PackageIndex) 29 | import Data.Time.Clock 30 | ( UTCTime ) 31 | import Data.Time.Clock.POSIX 32 | ( utcTimeToPOSIXSeconds ) 33 | import Data.Int (Int64) 34 | 35 | import Data.Map (Map) 36 | import qualified Data.Map as Map 37 | import Data.ByteString.Lazy (ByteString) 38 | import Prelude hiding (read) 39 | 40 | -- Construct, with the specified user database, extra top-level files, and 41 | -- a package index, an index tarball. This tarball has the modification times 42 | -- and uploading users built-in. 43 | write :: Users.Users -> Map String (ByteString, UTCTime) -> PackageIndex PkgInfo -> ByteString 44 | write users = PackageIndex.write (cabalFileByteString . pkgData) setModTime . extraEntries 45 | where 46 | setModTime pkgInfo entry = let (utime, uuser) = pkgUploadData pkgInfo in entry { 47 | Tar.entryTime = utcToUnixTime utime, 48 | Tar.entryOwnership = Tar.Ownership { 49 | Tar.ownerName = userName uuser, 50 | Tar.groupName = "HackageDB", 51 | Tar.ownerId = 0, 52 | Tar.groupId = 0 53 | } 54 | } 55 | utcToUnixTime :: UTCTime -> Int64 56 | utcToUnixTime = truncate . utcTimeToPOSIXSeconds 57 | userName = display . Users.idToName users 58 | extraEntries emap = do 59 | (path, (entry, mtime)) <- Map.toList emap 60 | Right tarPath <- return $ Tar.toTarPath False path 61 | return $ (Tar.fileEntry tarPath entry) { Tar.entryTime = utcToUnixTime mtime } 62 | 63 | -------------------------------------------------------------------------------- /Distribution/Server/Packages/ModuleForest.hs: -------------------------------------------------------------------------------- 1 | -- (C) Copyright by Bas van Dijk, v.dijk.bas@gmail.com, 2008 2 | -- Inspiration (read: copied, renamed and simplified) from: 3 | -- http://code.haskell.org/haddock/src/Haddock/ModuleTree.hs 4 | 5 | module Distribution.Server.Packages.ModuleForest ( ModuleForest, ModuleTree(..), moduleForest ) where 6 | 7 | import Distribution.ModuleName ( ModuleName, components ) 8 | 9 | -------------------------------------------------------------------------------- 10 | 11 | type ModuleForest = [ModuleTree] 12 | 13 | data ModuleTree = Node String -- Part of module name 14 | Bool -- Is this an existing module? 15 | ModuleForest -- Sub modules 16 | deriving (Show, Eq) 17 | 18 | -------------------------------------------------------------------------------- 19 | 20 | moduleForest :: [ModuleName] -> ModuleForest 21 | moduleForest = foldr (addToForest . components) [] 22 | 23 | addToForest :: [String] -> ModuleForest -> ModuleForest 24 | addToForest [] ts = ts 25 | addToForest ss [] = mkSubTree ss 26 | addToForest s1ss@(s1:ss) (t@(Node s2 isModule subs) : ts) 27 | | s1 > s2 = t : addToForest s1ss ts 28 | | s1 == s2 = Node s2 (isModule || null ss) (addToForest ss subs) : ts 29 | | otherwise = mkSubTree s1ss ++ t : ts 30 | 31 | mkSubTree :: [String] -> ModuleForest 32 | mkSubTree [] = [] 33 | mkSubTree (s:ss) = [Node s (null ss) (mkSubTree ss)] 34 | 35 | -------------------------------------------------------------------------------- 36 | 37 | -------------------------------------------------------------------------------- /Distribution/Server/Packages/Platform.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveDataTypeable, TypeFamilies, TemplateHaskell, 2 | FlexibleInstances, FlexibleContexts, MultiParamTypeClasses, 3 | TypeOperators, TypeSynonymInstances, GeneralizedNewtypeDeriving #-} 4 | 5 | module Distribution.Server.Packages.Platform where 6 | 7 | import Data.Acid (Query, Update, makeAcidic) 8 | import Data.Map (Map) 9 | import qualified Data.Map as Map 10 | import Data.SafeCopy (base, deriveSafeCopy) 11 | import Data.Set (Set) 12 | import qualified Data.Set as Set 13 | import Data.Typeable 14 | 15 | import Distribution.Server.Framework.Instances () 16 | import Distribution.Package 17 | import Distribution.Version 18 | 19 | import Control.Monad.Reader (ask, asks) 20 | import Control.Monad.State (put, modify) 21 | 22 | newtype PlatformPackages = PlatformPackages { 23 | blessedPackages :: Map PackageName (Set Version) 24 | } deriving (Show, Typeable) 25 | emptyPlatformPackages :: PlatformPackages 26 | emptyPlatformPackages = PlatformPackages Map.empty 27 | 28 | getPlatformPackages :: Query PlatformPackages PlatformPackages 29 | getPlatformPackages = ask 30 | 31 | getPlatformPackage :: PackageName -> Query PlatformPackages (Set Version) 32 | getPlatformPackage pkgname = asks (Map.findWithDefault Set.empty pkgname . blessedPackages) 33 | 34 | setPlatformPackage :: PackageName -> Set Version -> Update PlatformPackages () 35 | setPlatformPackage pkgname versions = modify $ \p -> case Set.null versions of 36 | True -> p { blessedPackages = Map.delete pkgname $ blessedPackages p } 37 | False -> p { blessedPackages = Map.insert pkgname versions $ blessedPackages p } 38 | 39 | replacePlatformPackages :: PlatformPackages -> Update PlatformPackages () 40 | replacePlatformPackages = put 41 | 42 | $(deriveSafeCopy 0 'base ''PlatformPackages) 43 | 44 | initialPlatformPackages :: PlatformPackages 45 | initialPlatformPackages = emptyPlatformPackages 46 | 47 | $(makeAcidic ''PlatformPackages ['getPlatformPackages 48 | ,'getPlatformPackage 49 | ,'setPlatformPackage 50 | ,'replacePlatformPackages 51 | ]) 52 | 53 | -------------------------------------------------------------------------------- /Distribution/Server/Pages/BuildReports.hs: -------------------------------------------------------------------------------- 1 | -- Generate an HTML page listing all build reports for a package 2 | 3 | module Distribution.Server.Pages.BuildReports ( 4 | buildReportSummary, 5 | buildReportDetail, 6 | ) where 7 | 8 | import qualified Distribution.Server.Features.BuildReports.BuildReport as BuildReport 9 | import Distribution.Server.Features.BuildReports.BuildReport (BuildReport) 10 | import Distribution.Server.Features.BuildReports.BuildReports 11 | import Distribution.Server.Pages.Template ( hackagePage ) 12 | 13 | import Distribution.Package 14 | ( PackageIdentifier ) 15 | import Distribution.PackageDescription 16 | ( FlagName(FlagName) ) 17 | import Distribution.Text 18 | ( Text, display ) 19 | 20 | import qualified Text.XHtml.Strict as XHtml 21 | import Text.XHtml.Strict 22 | ( Html, (<<), (!), tr, th, td, p, h2, ulist, li 23 | , toHtml, table, theclass, concatHtml, isNoHtml ) 24 | import Data.List (intersperse) 25 | 26 | buildReportSummary :: PackageIdentifier 27 | -> [(BuildReportId, BuildReport)] -> XHtml.Html 28 | buildReportSummary pkgid reports = hackagePage title body 29 | where 30 | title = display pkgid ++ ": build reports" 31 | body = [h2 << title, summaryTable] 32 | 33 | summaryTable = XHtml.table ! [theclass "properties"] << 34 | (headerRow : dataRows) 35 | headerRow = tr << [ th ! [XHtml.theclass "horizontal"] << 36 | columnName 37 | | columnName <- columnNames ] 38 | columnNames = ["Platform", "Compiler", "Build outcome"] 39 | dataRows = 40 | [ tr ! [theclass (if odd n then "odd" else "even")] << 41 | [ td << (display (BuildReport.arch report) 42 | ++ " / " 43 | ++ display (BuildReport.os report)) 44 | , td << display (BuildReport.compiler report) 45 | , td << detailLink reportId << 46 | display (BuildReport.installOutcome report) ] 47 | | (n, (reportId, report)) <- zip [(1::Int)..] reports ] 48 | detailLink reportId = 49 | XHtml.anchor ! [XHtml.href $ "/buildreports/" ++ display reportId ] 50 | 51 | buildReportDetail :: BuildReport -> BuildReportId -> Maybe BuildLog -> XHtml.Html 52 | buildReportDetail report reportId buildLog = hackagePage title body 53 | where 54 | title = display pkgid ++ ": build report" 55 | pkgid = BuildReport.package report 56 | body = [h2 << title, details, buildLogPara] 57 | details = tabulate 58 | [ (name, value) 59 | | (name, field) <- showFields 60 | , let value = field report 61 | , not (isNoHtml value) ] 62 | 63 | buildLogPara = p << [ ulist << [li << buildLogLink]] 64 | buildLogLink = case buildLog of 65 | Nothing -> toHtml "No build log available" 66 | _ -> XHtml.anchor ! [XHtml.href buildLogURL ] << "Build log" 67 | buildLogURL = "/buildreports/" ++ display reportId ++ "/buildlog" 68 | 69 | showFields :: [(String, BuildReport -> Html)] 70 | showFields = 71 | [ ("Package", displayHtml . BuildReport.package) 72 | , ("Platform", toHtml . platform) 73 | , ("Compiler", displayHtml . BuildReport.compiler) 74 | , ("Build client", displayHtml . BuildReport.client) 75 | , ("Configuration flags", displayHtmlFlags . BuildReport.flagAssignment) 76 | , ("Exact dependencies", displayHtmlList . BuildReport.dependencies) 77 | , ("Install outcome", displayHtml . BuildReport.installOutcome) 78 | , ("Docs outcome", displayHtml . BuildReport.docsOutcome) 79 | ] 80 | platform report' = display (BuildReport.arch report') 81 | ++ " / " 82 | ++ display (BuildReport.os report') 83 | displayHtml :: Text a => a -> Html 84 | displayHtml = toHtml . display 85 | displayHtmlList :: Text a => [a] -> Html 86 | displayHtmlList = concatHtml . intersperse (toHtml ", ") . map displayHtml 87 | displayHtmlFlags = concatHtml . intersperse (toHtml ", ") . map displayFlag 88 | displayFlag (FlagName fname, False) = toHtml $ '-':fname 89 | displayFlag (FlagName fname, True) = toHtml $ fname 90 | 91 | tabulate :: [(String, Html)] -> Html 92 | tabulate items = table ! [theclass "properties"] << 93 | [tr ! [theclass (if odd n then "odd" else "even")] << 94 | [th ! [theclass "horizontal"] << t, td << d] | 95 | (n, (t, d)) <- zip [(1::Int)..] items] 96 | 97 | -------------------------------------------------------------------------------- /Distribution/Server/Pages/Distributions.hs: -------------------------------------------------------------------------------- 1 | 2 | module Distribution.Server.Pages.Distributions 3 | ( homePage 4 | , adminHomePage 5 | , distroListing 6 | , distroPage 7 | , adminDistroPage 8 | ) 9 | where 10 | 11 | import Distribution.Server.Pages.Template (hackagePage) 12 | import Distribution.Server.Features.Distro.Distributions 13 | import Distribution.Server.Users.Types 14 | import Distribution.Text 15 | 16 | import Distribution.Package 17 | import qualified Happstack.Server.SURI as SURI 18 | 19 | import System.FilePath.Posix 20 | import Text.XHtml.Strict 21 | 22 | -- | List of known distributions 23 | homePage :: [DistroName] -> Html 24 | homePage = hackagePage "Distributions" . listing "/distro" 25 | 26 | -- | List of known distributions. Includes a form 27 | -- to add a new distribution. 28 | adminHomePage :: [DistroName] -> Html 29 | adminHomePage distros 30 | = hackagePage "Distributions" $ concat 31 | [ listing "/admin/distro" distros 32 | , addDistroForm 33 | ] 34 | 35 | -- | Display the packages in a distribution. The passed-in URL is the 36 | -- link to the admin page. 37 | distroListing :: DistroName -> [(PackageName, DistroPackageInfo)] -> URL -> Html 38 | distroListing distro packages adminLink 39 | = hackagePage (display distro) $ concat 40 | [ packageListing 41 | , adminLinkHtml 42 | ] 43 | 44 | where 45 | packageListing :: [Html] 46 | packageListing 47 | = [ h3 << ("Packages in " ++ display distro) 48 | , ulist << map (uncurry packageHtml) packages 49 | ] 50 | 51 | packageHtml pName pInfo 52 | = li << (display pName ++ " " ++ display (distroVersion pInfo)) 53 | 54 | adminLinkHtml 55 | = [ h3 << "Admin Tasks" 56 | , anchor ! [href adminLink] << "Administrative tasks" 57 | ] 58 | 59 | -- | Admin page for a distribution. Includes a list 60 | -- of the maintainers and a form to add maintainers. 61 | distroPage :: DistroName -> [UserName] -> Html 62 | distroPage distro users 63 | = hackagePage (display distro) $ concat 64 | [ addPackageForm distro 65 | , userList distro users 66 | , addUserForm distro 67 | ] 68 | 69 | addPackageForm :: DistroName -> [Html] 70 | addPackageForm distro = 71 | let actionUri = 72 | "/distro" SURI.escape distro "admin" "addPackage" 73 | in [ h3 << "Add a package" 74 | , gui actionUri ! [theclass "box"] << 75 | [ p << [stringToHtml "Package: ", textfield "packageName"] 76 | , p << [stringToHtml "Version: ", textfield "version"] 77 | , p << [stringToHtml "URL: ", textfield "uri"] 78 | , submit "submit" "Add package" 79 | ] 80 | ] 81 | 82 | addDistroForm :: [Html] 83 | addDistroForm = 84 | [ h3 << "Add Distribution" 85 | , gui "/admin/createDistro" ! [theclass "box"] << 86 | [ p << [stringToHtml "Name: ", textfield "distroName"] 87 | , submit "submit" "Add distribution" 88 | ] 89 | ] 90 | 91 | {- 92 | This should be updated to match the current URI scheme in the Distro feature. 93 | 94 | displayDir :: Text a => a -> String 95 | displayDir = escapeString f . display 96 | where f c = okInPath c && c /= '/' 97 | 98 | -- | Admin form for a distribution. Includes a list 99 | -- of the maintainers, a form to add maintainers and 100 | -- a button to destroy this distribution. 101 | adminDistroPage :: DistroName -> [UserName] -> Html 102 | adminDistroPage distro users 103 | = hackagePage (display distro) $ concat 104 | [ userList distro users 105 | , addUserForm distro 106 | , deleteDistro distro 107 | ] 108 | 109 | addUserForm :: DistroName -> [Html] 110 | addUserForm distro = 111 | [ h3 << "Add a maintainer" 112 | , gui ("/distro" displayDir distro "admin" "addMember") ! [theclass "box"] 113 | << [ p << [stringToHtml "User: ", textfield "userName"] 114 | , submit "submit" "Add user" 115 | ] 116 | ] 117 | 118 | deleteDistro :: DistroName -> [Html] 119 | deleteDistro distro 120 | = [ h3 << "Delete distribution" 121 | , gui ("/admin/distro" displayDir distro "delete") << 122 | submit "submit" "Delete Distribution" 123 | ] 124 | 125 | userList :: DistroName -> [UserName] -> [Html] 126 | userList distro users 127 | = [ h3 << "Maintainers" 128 | , ulist << map (userHtml distro) users 129 | ] 130 | 131 | userHtml :: DistroName -> UserName -> Html 132 | userHtml distro user 133 | = li << [ stringToHtml $ display user 134 | , removeUser user distro 135 | ] 136 | 137 | removeUser :: UserName -> DistroName -> Html 138 | removeUser user distro 139 | = gui ("/distro" displayDir distro "admin" "removeMember") 140 | << [ hidden "userName" $ display user 141 | , submit "submit" "Remove" 142 | ]-} 143 | 144 | listing :: FilePath -> [DistroName] -> [Html] 145 | listing rootPath distros 146 | = [ h3 << "Distributions" 147 | , ulist << map (distroHtml rootPath) distros 148 | ] 149 | 150 | distroHtml :: FilePath -> DistroName -> Html 151 | distroHtml rootPath distro 152 | = li << anchor ! [href $ rootPath SURI.escape distro ] 153 | << display distro 154 | -------------------------------------------------------------------------------- /Distribution/Server/Pages/Group.hs: -------------------------------------------------------------------------------- 1 | -- Body of the HTML page for a package 2 | module Distribution.Server.Pages.Group ( 3 | groupPage, 4 | renderGroupName 5 | ) where 6 | 7 | import Text.XHtml.Strict 8 | import System.FilePath.Posix (()) 9 | import Distribution.Server.Pages.Template (hackagePage) 10 | import qualified Distribution.Server.Users.Types as Users 11 | import Distribution.Server.Users.Group (GroupDescription(..)) 12 | import qualified Distribution.Server.Users.Group as Group 13 | import Distribution.Text 14 | import Data.Maybe 15 | 16 | renderGroupName :: GroupDescription -> Maybe String -> Html 17 | renderGroupName desc murl = 18 | maybeUrl (groupTitle desc) murl 19 | +++ 20 | maybe noHtml (\(for, mfor) -> " for " +++ maybeUrl for mfor) (groupEntity desc) 21 | where maybeUrl text = maybe (toHtml text) (\url -> anchor ! [href url] << text) 22 | 23 | -- Primitive access control: the URI to post a new user request to, or the the URI/user/ to DELETE 24 | -- if neither adding or removing is enabled, a link to a URI/edit page is provided 25 | groupPage :: [Users.UserName] -> String -> (Bool, Bool) -> GroupDescription -> Html 26 | groupPage users baseUri controls desc = hackagePage (Group.groupName desc) (groupBody users baseUri controls desc) 27 | 28 | -- | Body of the page 29 | -- If either addUri or removeUri are true, it can be assumed that we are one the 30 | -- \/edit subpage of the group. 31 | groupBody :: [Users.UserName] -> String -> (Bool, Bool) -> GroupDescription -> [Html] 32 | groupBody users baseUri (addUri, removeUri) desc = 33 | [ h2 << renderGroupName desc (if addUri || removeUri then Just baseUri else Nothing) 34 | , paragraph << 35 | [ toHtml $ groupPrologue desc 36 | , if addUri || removeUri then noHtml else thespan ! [thestyle "color: gray"] << 37 | [ toHtml " [" 38 | , anchor ! [href $ baseUri "edit"] << "edit" 39 | , toHtml "]" 40 | ] 41 | ] 42 | , listGroup users (if removeUri then Just baseUri else Nothing) 43 | , if addUri then concatHtml $ addUser baseUri else noHtml 44 | ] 45 | 46 | addUser :: String -> [Html] 47 | addUser uri = 48 | [ h3 << "Add user" 49 | , gui uri ! [theclass "box"] << 50 | [ p << [stringToHtml "User: ", textfield "user"] 51 | , submit "submit" "Add member" 52 | ] 53 | ] 54 | 55 | removeUser :: Users.UserName -> String -> [Html] 56 | removeUser uname uri = 57 | [ toHtml " ", 58 | gui (uri "user" display uname) << 59 | [ hidden "_method" "DELETE" 60 | , submit "submit" "Remove" 61 | ] 62 | ] 63 | 64 | listGroup :: [Users.UserName] -> Maybe String -> Html 65 | listGroup [] _ = p << "No member exist presently" 66 | listGroup users muri = p << unordList (map displayName users) 67 | where displayName uname = (anchor ! [href $ "/user/" ++ display uname] << display uname) +++ 68 | fromMaybe [] (fmap (removeUser uname) muri) 69 | 70 | -------------------------------------------------------------------------------- /Distribution/Server/Pages/Index.hs: -------------------------------------------------------------------------------- 1 | -- Generate an HTML page listing all available packages 2 | 3 | module Distribution.Server.Pages.Index (packageIndex) where 4 | 5 | import Distribution.Server.Pages.Template ( hackagePage ) 6 | 7 | import Distribution.Package 8 | import Distribution.PackageDescription 9 | import Distribution.PackageDescription.Configuration 10 | ( flattenPackageDescription ) 11 | import qualified Distribution.Server.Packages.PackageIndex as PackageIndex 12 | import Distribution.Server.Packages.Types (PkgInfo(..)) 13 | import Distribution.Simple.Utils (comparing, equating) 14 | import Distribution.ModuleName (toFilePath) 15 | 16 | import Text.XHtml.Strict hiding ( p, name ) 17 | import qualified Text.XHtml.Strict as XHtml ( name ) 18 | 19 | import Data.Char (toLower, toUpper, isSpace) 20 | import Data.List (intersperse, sortBy, groupBy, nub, maximumBy) 21 | 22 | 23 | packageIndex :: PackageIndex.PackageIndex PkgInfo -> Html 24 | packageIndex = formatPkgGroups 25 | . map (flattenPackageDescription 26 | . pkgDesc 27 | . maximumBy (comparing packageVersion)) 28 | . PackageIndex.allPackagesByName 29 | 30 | data Category = Category String | NoCategory 31 | deriving (Eq, Ord, Show) 32 | 33 | -- Packages, grouped by category and ordered by name with each category. 34 | formatPkgGroups :: [PackageDescription] -> Html 35 | formatPkgGroups pkgs = hackagePage "packages by category" docBody 36 | where docBody = 37 | (thediv ! [theclass "floatright"] << searchBox) : 38 | (h2 << "Packages by category") : 39 | -- table of contents 40 | paragraph ! [theclass "toc"] << 41 | (bold << "Categories:" : toHtml " " : 42 | intersperse (toHtml ", ") (map catLink cat_pkgs) ++ 43 | [toHtml "."]) : 44 | -- packages grouped by category 45 | [formatCategory cat +++ 46 | formatPkgList (sortBy (comparing sortKey) sub_pkgs) | 47 | (cat, sub_pkgs) <- cat_pkgs] 48 | searchBox = 49 | [form ! [method "get", action "http://www.google.co.uk/search"] << 50 | [input ! [thetype "hidden", XHtml.name "hl", value "en"], 51 | input ! [thetype "hidden", XHtml.name "as_sitesearch", value "hackage.haskell.org/packages"], 52 | input ! [thetype "text", size "20", XHtml.name "as_q", value ""], 53 | input ! [thetype "submit", value "Search package pages"] 54 | ]] 55 | catLink (cat, sub_pkgs) = 56 | (anchor ! [href ("#" ++ catLabel catName)] << catName) +++ 57 | spaceHtml +++ 58 | toHtml ("(" ++ show (length sub_pkgs) ++ ")") 59 | where catName = categoryName cat 60 | cat_pkgs = groupOnFstBy normalizeCategory $ [(capitalize cat, pkg) | 61 | pkg <- pkgs, cat <- categories pkg] 62 | sortKey pkg = map toLower $ unPackageName $ pkgName $ package pkg 63 | formatCategory cat = 64 | h3 ! [theclass "category"] << 65 | anchor ! [XHtml.name (catLabel catName)] << catName 66 | where catName = categoryName cat 67 | catLabel cat = "cat:" ++ cat 68 | categoryName (Category cat) = cat 69 | categoryName NoCategory = "Unclassified" 70 | capitalize (Category s) = 71 | Category (unwords [toUpper c : cs | (c:cs) <- words s]) 72 | capitalize NoCategory = NoCategory 73 | 74 | formatPkgList :: [PackageDescription] -> Html 75 | formatPkgList pkgs = ulist ! [theclass "packages"] << map formatPkg pkgs 76 | 77 | formatPkg :: PackageDescription -> Html 78 | formatPkg pkg = li << (pkgLink : toHtml (" " ++ ptype) : defn) 79 | where pname = pkgName (package pkg) 80 | pkgLink = anchor ! [href (packageNameURL pname)] << unPackageName pname 81 | defn 82 | | null (synopsis pkg) = [] 83 | | otherwise = [toHtml (": " ++ trim (synopsis pkg))] 84 | ptype 85 | | null (executables pkg) = "library" 86 | | hasLibs pkg = "library and " ++ programs 87 | | otherwise = programs 88 | where programs 89 | | length (executables pkg) > 1 = "programs" 90 | | otherwise = "program" 91 | trim s 92 | | length s < 90 = s 93 | | otherwise = reverse (dropWhile (/= ',') (reverse (take 76 s))) ++ " ..." 94 | 95 | categories :: PackageDescription -> [Category] 96 | categories pkg 97 | | not (null cats) && (cats `notElem` blacklist) = split cats 98 | | not (null top_level_nodes) && length top_level_nodes < 3 && 99 | all (`elem` allocatedTopLevelNodes) top_level_nodes = 100 | map Category top_level_nodes 101 | | otherwise = [NoCategory] 102 | where cats = trim (category pkg) 103 | -- trim will not be necessary with future releases of cabal 104 | trim = reverse . dropWhile isSpace . reverse 105 | split cs = case break (== ',') cs of 106 | (front, _:back) -> 107 | Category front : split (dropWhile isSpace back) 108 | (front, []) -> [Category front] 109 | -- if no category specified, use top-level of module hierarchy 110 | top_level_nodes = 111 | maybe [] (nub . map (takeWhile (/= '.') . toFilePath) . exposedModules) 112 | (library pkg) 113 | 114 | -- categories we ignore 115 | blacklist :: [String] 116 | blacklist = ["Application", "Foreign binding", "Tool", "Type", "Various", 117 | "Unclassified"] 118 | 119 | groupOnFstBy :: (Ord a, Ord c) => (a -> c) -> [(a, b)] -> [(a, [b])] 120 | groupOnFstBy f xys = [(x, y : map snd xys') | 121 | (x, y) : xys' <- groupBy (equating (f . fst)) (sortBy (comparing sortKey) xys)] 122 | where sortKey (x, _) = (f x, x) 123 | 124 | normalizeCategory :: Category -> Category 125 | normalizeCategory (Category n) = Category (map toLower n) 126 | normalizeCategory NoCategory = NoCategory 127 | 128 | allocatedTopLevelNodes :: [String] 129 | allocatedTopLevelNodes = [ 130 | "Algebra", "Codec", "Control", "Data", "Database", "Debug", 131 | "Distribution", "DotNet", "Foreign", "Graphics", "Language", 132 | "Network", "Numeric", "Prelude", "Sound", "System", "Test", "Text"] 133 | 134 | packageNameURL :: PackageName -> URL 135 | packageNameURL pkg = "/package/" ++ unPackageName pkg 136 | 137 | unPackageName :: PackageName -> String 138 | unPackageName (PackageName name) = name 139 | -------------------------------------------------------------------------------- /Distribution/Server/Pages/Package/HaddockHtml.hs: -------------------------------------------------------------------------------- 1 | -- stolen from Haddock's HsSyn.lhs and HaddockHtml.hs 2 | module Distribution.Server.Pages.Package.HaddockHtml where 3 | 4 | import Data.Char (isSpace) 5 | import Text.XHtml.Strict hiding (p) 6 | import Network.URI (escapeURIString, isUnreserved) 7 | 8 | data GenDoc id 9 | = DocEmpty 10 | | DocAppend (GenDoc id) (GenDoc id) 11 | | DocString String 12 | | DocParagraph (GenDoc id) 13 | | DocIdentifier id 14 | | DocModule String 15 | | DocEmphasis (GenDoc id) 16 | | DocMonospaced (GenDoc id) 17 | | DocUnorderedList [GenDoc id] 18 | | DocOrderedList [GenDoc id] 19 | | DocDefList [(GenDoc id, GenDoc id)] 20 | | DocCodeBlock (GenDoc id) 21 | | DocURL String 22 | | DocPic String 23 | | DocAName String 24 | deriving (Eq, Show) 25 | 26 | type Doc = GenDoc String 27 | 28 | -- | DocMarkup is a set of instructions for marking up documentation. 29 | -- In fact, it's really just a mapping from 'GenDoc' to some other 30 | -- type [a], where [a] is usually the type of the output (HTML, say). 31 | 32 | data DocMarkup id a = Markup { 33 | markupEmpty :: a, 34 | markupString :: String -> a, 35 | markupParagraph :: a -> a, 36 | markupAppend :: a -> a -> a, 37 | markupIdentifier :: id -> a, 38 | markupModule :: String -> a, 39 | markupEmphasis :: a -> a, 40 | markupMonospaced :: a -> a, 41 | markupUnorderedList :: [a] -> a, 42 | markupOrderedList :: [a] -> a, 43 | markupDefList :: [(a,a)] -> a, 44 | markupCodeBlock :: a -> a, 45 | markupURL :: String -> a, 46 | markupPic :: String -> a, 47 | markupAName :: String -> a 48 | } 49 | 50 | markup :: DocMarkup id a -> GenDoc id -> a 51 | markup m DocEmpty = markupEmpty m 52 | markup m (DocAppend d1 d2) = markupAppend m (markup m d1) (markup m d2) 53 | markup m (DocString s) = markupString m s 54 | markup m (DocParagraph d) = markupParagraph m (markup m d) 55 | markup m (DocIdentifier i) = markupIdentifier m i 56 | markup m (DocModule mod0) = markupModule m mod0 57 | markup m (DocEmphasis d) = markupEmphasis m (markup m d) 58 | markup m (DocMonospaced d) = markupMonospaced m (markup m d) 59 | markup m (DocUnorderedList ds) = markupUnorderedList m (map (markup m) ds) 60 | markup m (DocOrderedList ds) = markupOrderedList m (map (markup m) ds) 61 | markup m (DocDefList ds) = markupDefList m (map (markupPair m) ds) 62 | markup m (DocCodeBlock d) = markupCodeBlock m (markup m d) 63 | markup m (DocURL url) = markupURL m url 64 | markup m (DocPic url) = markupPic m url 65 | markup m (DocAName ref) = markupAName m ref 66 | 67 | markupPair :: DocMarkup id a -> (GenDoc id, GenDoc id) -> (a, a) 68 | markupPair m (a,b) = (markup m a, markup m b) 69 | 70 | -- | The identity markup 71 | idMarkup :: DocMarkup a (GenDoc a) 72 | idMarkup = Markup { 73 | markupEmpty = DocEmpty, 74 | markupString = DocString, 75 | markupParagraph = DocParagraph, 76 | markupAppend = DocAppend, 77 | markupIdentifier = DocIdentifier, 78 | markupModule = DocModule, 79 | markupEmphasis = DocEmphasis, 80 | markupMonospaced = DocMonospaced, 81 | markupUnorderedList = DocUnorderedList, 82 | markupOrderedList = DocOrderedList, 83 | markupDefList = DocDefList, 84 | markupCodeBlock = DocCodeBlock, 85 | markupURL = DocURL, 86 | markupPic = DocPic, 87 | markupAName = DocAName 88 | } 89 | 90 | htmlMarkup :: DocMarkup String Html 91 | htmlMarkup = Markup { 92 | markupParagraph = paragraph, 93 | markupEmpty = toHtml "", 94 | markupString = toHtml, 95 | markupAppend = (+++), 96 | markupIdentifier = tt . toHtml . init . tail, 97 | markupModule = tt . toHtml, 98 | markupEmphasis = emphasize . toHtml, 99 | markupMonospaced = tt . toHtml, 100 | markupUnorderedList = ulist . concatHtml . map (li <<), 101 | markupOrderedList = olist . concatHtml . map (li <<), 102 | markupDefList = dlist . concatHtml . map markupDef, 103 | markupCodeBlock = pre, 104 | markupURL = \url -> anchor ! [href url] << toHtml url, 105 | markupPic = \url -> image ! [src url], 106 | markupAName = \aname -> namedAnchor aname << toHtml "" 107 | } 108 | where markupDef (a,b) = dterm << a +++ ddef << b 109 | 110 | namedAnchor :: String -> Html -> Html 111 | namedAnchor n = anchor ! [name (escapeStr n)] 112 | 113 | escapeStr :: String -> String 114 | escapeStr = escapeURIString isUnreserved 115 | 116 | -- ----------------------------------------------------------------------------- 117 | -- ** Smart constructors 118 | 119 | -- used to make parsing easier; we group the list items later 120 | docAppend :: Doc -> Doc -> Doc 121 | docAppend (DocUnorderedList ds1) (DocUnorderedList ds2) 122 | = DocUnorderedList (ds1++ds2) 123 | docAppend (DocUnorderedList ds1) (DocAppend (DocUnorderedList ds2) d) 124 | = DocAppend (DocUnorderedList (ds1++ds2)) d 125 | docAppend (DocOrderedList ds1) (DocOrderedList ds2) 126 | = DocOrderedList (ds1++ds2) 127 | docAppend (DocOrderedList ds1) (DocAppend (DocOrderedList ds2) d) 128 | = DocAppend (DocOrderedList (ds1++ds2)) d 129 | docAppend (DocDefList ds1) (DocDefList ds2) 130 | = DocDefList (ds1++ds2) 131 | docAppend (DocDefList ds1) (DocAppend (DocDefList ds2) d) 132 | = DocAppend (DocDefList (ds1++ds2)) d 133 | docAppend DocEmpty d = d 134 | docAppend d DocEmpty = d 135 | docAppend d1 d2 136 | = DocAppend d1 d2 137 | 138 | -- again to make parsing easier - we spot a paragraph whose only item 139 | -- is a DocMonospaced and make it into a DocCodeBlock 140 | docParagraph :: Doc -> Doc 141 | docParagraph (DocMonospaced p) 142 | = DocCodeBlock p 143 | docParagraph (DocAppend (DocString s1) (DocMonospaced p)) 144 | | all isSpace s1 145 | = DocCodeBlock p 146 | docParagraph (DocAppend (DocString s1) 147 | (DocAppend (DocMonospaced p) (DocString s2))) 148 | | all isSpace s1 && all isSpace s2 149 | = DocCodeBlock p 150 | docParagraph (DocAppend (DocMonospaced p) (DocString s2)) 151 | | all isSpace s2 152 | = DocCodeBlock p 153 | docParagraph p 154 | = DocParagraph p 155 | -------------------------------------------------------------------------------- /Distribution/Server/Pages/Package/HaddockLex.x: -------------------------------------------------------------------------------- 1 | -- 2 | -- Haddock - A Haskell Documentation Tool 3 | -- 4 | -- (c) Simon Marlow 2002 5 | -- 6 | 7 | { 8 | {-# OPTIONS_GHC -w #-} 9 | {-# LANGUAGE BangPatterns #-} 10 | module Distribution.Server.Pages.Package.HaddockLex ( 11 | Token(..), 12 | tokenise 13 | ) where 14 | 15 | import Data.Char 16 | import Numeric 17 | } 18 | 19 | $ws = $white # \n 20 | $digit = [0-9] 21 | $hexdigit = [0-9a-fA-F] 22 | $special = [\"\@] 23 | $alphanum = [A-Za-z0-9] 24 | $ident = [$alphanum \'\_\.\!\#\$\%\&\*\+\/\<\=\>\?\@\\\\\^\|\-\~] 25 | 26 | :- 27 | 28 | -- beginning of a paragraph 29 | <0,para> { 30 | $ws* \n ; 31 | $ws* \> { begin birdtrack } 32 | $ws* [\*\-] { token TokBullet `andBegin` string } 33 | $ws* \[ { token TokDefStart `andBegin` def } 34 | $ws* \( $digit+ \) { token TokNumber `andBegin` string } 35 | $ws* { begin string } 36 | } 37 | 38 | -- beginning of a line 39 | { 40 | $ws* \> { begin birdtrack } 41 | $ws* \n { token TokPara `andBegin` para } 42 | -- Here, we really want to be able to say 43 | -- $ws* (\n | ) { token TokPara `andBegin` para} 44 | -- because otherwise a trailing line of whitespace will result in 45 | -- a spurious TokString at the end of a docstring. We don't have , 46 | -- though (NOW I realise what it was for :-). To get around this, we always 47 | -- append \n to the end of a docstring. 48 | () { begin string } 49 | } 50 | 51 | .* \n? { strtoken TokBirdTrack `andBegin` line } 52 | 53 | { 54 | $special { strtoken $ \s -> TokSpecial (head s) } 55 | \<\<.*\>\> { strtoken $ \s -> TokPic (init $ init $ tail $ tail s) } 56 | \<.*\> { strtoken $ \s -> TokURL (init (tail s)) } 57 | \#.*\# { strtoken $ \s -> TokAName (init (tail s)) } 58 | \/ [^\/]* \/ { strtoken $ \s -> TokEmphasis (init (tail s)) } 59 | [\'\`] $ident+ [\'\`] { ident } 60 | \\ . { strtoken (TokString . tail) } 61 | "&#" $digit+ \; { strtoken $ \s -> TokString [chr (read (init (drop 2 s)))] } 62 | "&#" [xX] $hexdigit+ \; { strtoken $ \s -> case readHex (init (drop 3 s)) of [(n,_)] -> TokString [chr n] } 63 | -- allow special characters through if they don't fit one of the previous 64 | -- patterns. 65 | [\/\'\`\<\#\&\\] { strtoken TokString } 66 | [^ $special \/ \< \# \n \'\` \& \\ \]]* \n { strtoken TokString `andBegin` line } 67 | [^ $special \/ \< \# \n \'\` \& \\ \]]+ { strtoken TokString } 68 | } 69 | 70 | { 71 | \] { token TokDefEnd `andBegin` string } 72 | } 73 | 74 | -- ']' doesn't have any special meaning outside of the [...] at the beginning 75 | -- of a definition paragraph. 76 | { 77 | \] { strtoken TokString } 78 | } 79 | 80 | { 81 | data Token 82 | = TokPara 83 | | TokNumber 84 | | TokBullet 85 | | TokDefStart 86 | | TokDefEnd 87 | | TokSpecial Char 88 | | TokIdent String 89 | | TokString String 90 | | TokURL String 91 | | TokPic String 92 | | TokEmphasis String 93 | | TokAName String 94 | | TokBirdTrack String 95 | deriving Show 96 | 97 | -- ----------------------------------------------------------------------------- 98 | -- Alex support stuff 99 | 100 | type StartCode = Int 101 | type Action = String -> StartCode -> (StartCode -> [Token]) -> [Token] 102 | 103 | type AlexInput = (Char,String) 104 | 105 | alexGetChar (_, []) = Nothing 106 | alexGetChar (_, c:cs) = Just (c, (c,cs)) 107 | 108 | alexInputPrevChar (c,_) = c 109 | 110 | tokenise :: String -> [Token] 111 | tokenise str = let toks = go ('\n', eofHack str) para in {-trace (show toks)-} toks 112 | where go inp@(_,str) sc = 113 | case alexScan inp sc of 114 | AlexEOF -> [] 115 | AlexError _ -> error "lexical error" 116 | AlexSkip inp' _ -> go inp' sc 117 | AlexToken inp' len act -> act (take len str) sc (\sc -> go inp' sc) 118 | 119 | -- NB. we add a final \n to the string, (see comment in the beginning of line 120 | -- production above). 121 | eofHack str = str++"\n" 122 | 123 | andBegin :: Action -> StartCode -> Action 124 | andBegin act new_sc = \str _ cont -> act str new_sc cont 125 | 126 | token :: Token -> Action 127 | token t = \_ sc cont -> t : cont sc 128 | 129 | strtoken :: (String -> Token) -> Action 130 | strtoken t = \str sc cont -> t str : cont sc 131 | 132 | begin :: StartCode -> Action 133 | begin sc = \_ _ cont -> cont sc 134 | 135 | -- ----------------------------------------------------------------------------- 136 | -- Lex a string as a Haskell identifier 137 | 138 | ident :: Action 139 | ident str sc cont = TokIdent str : cont sc 140 | } 141 | -------------------------------------------------------------------------------- /Distribution/Server/Pages/Package/HaddockParse.y: -------------------------------------------------------------------------------- 1 | { 2 | {-# OPTIONS_GHC -w #-} 3 | module Distribution.Server.Pages.Package.HaddockParse (parseHaddockParagraphs) where 4 | 5 | import Distribution.Server.Pages.Package.HaddockLex 6 | import Distribution.Server.Pages.Package.HaddockHtml 7 | 8 | import Control.Monad.Error () 9 | } 10 | 11 | %tokentype { Token } 12 | 13 | %token 14 | '@' { TokSpecial '@' } 15 | '[' { TokDefStart } 16 | ']' { TokDefEnd } 17 | DQUO { TokSpecial '\"' } 18 | URL { TokURL $$ } 19 | PIC { TokPic $$ } 20 | ANAME { TokAName $$ } 21 | '/../' { TokEmphasis $$ } 22 | '-' { TokBullet } 23 | '(n)' { TokNumber } 24 | '>..' { TokBirdTrack $$ } 25 | IDENT { TokIdent $$ } 26 | PARA { TokPara } 27 | STRING { TokString $$ } 28 | 29 | %monad { Either String } 30 | 31 | %name parseHaddockParagraphs doc 32 | %name parseHaddockString seq 33 | 34 | %% 35 | 36 | doc :: { Doc } 37 | : apara PARA doc { docAppend $1 $3 } 38 | | PARA doc { $2 } 39 | | apara { $1 } 40 | | {- empty -} { DocEmpty } 41 | 42 | apara :: { Doc } 43 | : ulpara { DocUnorderedList [$1] } 44 | | olpara { DocOrderedList [$1] } 45 | | defpara { DocDefList [$1] } 46 | | para { $1 } 47 | 48 | ulpara :: { Doc } 49 | : '-' para { $2 } 50 | 51 | olpara :: { Doc } 52 | : '(n)' para { $2 } 53 | 54 | defpara :: { (Doc,Doc) } 55 | : '[' seq ']' seq { ($2, $4) } 56 | 57 | para :: { Doc } 58 | : seq { docParagraph $1 } 59 | | codepara { DocCodeBlock $1 } 60 | 61 | codepara :: { Doc } 62 | : '>..' codepara { docAppend (DocString $1) $2 } 63 | | '>..' { DocString $1 } 64 | 65 | seq :: { Doc } 66 | : elem seq { docAppend $1 $2 } 67 | | elem { $1 } 68 | 69 | elem :: { Doc } 70 | : elem1 { $1 } 71 | | '@' seq1 '@' { DocMonospaced $2 } 72 | 73 | seq1 :: { Doc } 74 | : PARA seq1 { docAppend (DocString "\n") $2 } 75 | | elem1 seq1 { docAppend $1 $2 } 76 | | elem1 { $1 } 77 | 78 | elem1 :: { Doc } 79 | : STRING { DocString $1 } 80 | | '/../' { DocEmphasis (DocString $1) } 81 | | URL { DocURL $1 } 82 | | PIC { DocPic $1 } 83 | | ANAME { DocAName $1 } 84 | | IDENT { DocIdentifier $1 } 85 | | DQUO strings DQUO { DocModule $2 } 86 | 87 | strings :: { String } 88 | : STRING { $1 } 89 | | STRING strings { $1 ++ $2 } 90 | 91 | { 92 | happyError :: [Token] -> Either String a 93 | happyError toks = 94 | Left ("parse error in doc string: " ++ show (take 3 toks)) 95 | } 96 | -------------------------------------------------------------------------------- /Distribution/Server/Pages/Recent.hs: -------------------------------------------------------------------------------- 1 | -- Takes a reversed log file on the standard input and outputs web page. 2 | 3 | module Distribution.Server.Pages.Recent ( 4 | recentPage, 5 | recentFeed, 6 | ) where 7 | 8 | import Distribution.Server.Packages.Types 9 | ( PkgInfo(..) ) 10 | import qualified Distribution.Server.Users.Users as Users 11 | import Distribution.Server.Users.Users (Users) 12 | import Distribution.Server.Pages.Template 13 | ( hackagePageWith ) 14 | 15 | import Distribution.Package 16 | ( PackageIdentifier, packageName, packageVersion, PackageName(..) ) 17 | import Distribution.PackageDescription 18 | ( GenericPackageDescription(packageDescription) 19 | , PackageDescription(synopsis) ) 20 | import Distribution.Text 21 | ( display ) 22 | 23 | import qualified Text.XHtml.Strict as XHtml 24 | import Text.XHtml 25 | ( Html, URL, (<<), (!) ) 26 | import qualified Text.RSS as RSS 27 | import Text.RSS 28 | ( RSS(RSS) ) 29 | import Network.URI 30 | ( URI(..), URIAuth(..), uriToString ) 31 | import Data.Time.Clock 32 | ( UTCTime ) 33 | import Data.Time.Clock.POSIX 34 | ( utcTimeToPOSIXSeconds ) 35 | import Data.Time.Format 36 | ( formatTime ) 37 | import System.Locale 38 | ( defaultTimeLocale ) 39 | 40 | 41 | -- | Takes a list of package info, in reverse order by timestamp. 42 | -- 43 | recentPage :: Users -> [PkgInfo] -> Html 44 | recentPage users pkgs = 45 | let log_rows = map (makeRow users) (take 20 pkgs) 46 | docBody = [XHtml.h2 << "Recent additions", 47 | XHtml.table ! [XHtml.align "center"] << log_rows] 48 | rss_link = XHtml.thelink ! [XHtml.rel "alternate", 49 | XHtml.thetype "application/rss+xml", 50 | XHtml.title "HackageDB RSS Feed", 51 | XHtml.href rssFeedURL] << XHtml.noHtml 52 | in hackagePageWith [rss_link] "recent additions" docBody 53 | 54 | makeRow :: Users -> PkgInfo -> Html 55 | makeRow users PkgInfo { 56 | pkgInfoId = pkgid 57 | , pkgUploadData = (time, userId) 58 | } = 59 | XHtml.tr << 60 | [XHtml.td ! [XHtml.align "right"] << 61 | [XHtml.toHtml (showTime time), nbsp, nbsp], 62 | XHtml.td ! [XHtml.align "left"] << display user, 63 | XHtml.td ! [XHtml.align "left"] << 64 | [nbsp, nbsp, XHtml.anchor ! 65 | [XHtml.href (packageURL pkgid)] << display pkgid]] 66 | where nbsp = XHtml.primHtmlChar "nbsp" 67 | user = Users.idToName users userId 68 | 69 | showTime :: UTCTime -> String 70 | showTime = formatTime defaultTimeLocale "%c" 71 | 72 | -- | URL describing a package. 73 | packageURL :: PackageIdentifier -> URL 74 | packageURL pkgid = "/package/" ++ display pkgid 75 | 76 | rssFeedURL :: URL 77 | rssFeedURL = "/recent.rss" 78 | 79 | recentAdditionsURL :: URL 80 | recentAdditionsURL = "/recent.html" 81 | 82 | recentFeed :: Users -> URIAuth -> UTCTime -> [PkgInfo] -> RSS 83 | recentFeed users host now pkgs = RSS 84 | "Recent additions" 85 | (hackageURI host recentAdditionsURL) 86 | desc 87 | (channel now) 88 | [ releaseItem users host pkg | pkg <- take 20 pkgs ] 89 | where 90 | desc = "The 20 most recent additions to HackageDB, the Haskell package database." 91 | 92 | hackageURI :: URIAuth -> String -> URI 93 | hackageURI host path = 94 | URI "http:" (Just host) path "" "" 95 | 96 | channel :: UTCTime -> [RSS.ChannelElem] 97 | channel now = 98 | [ RSS.Language "en" 99 | , RSS.ManagingEditor email 100 | , RSS.WebMaster email 101 | , RSS.ChannelPubDate now 102 | , RSS.LastBuildDate now 103 | , RSS.Generator "rss-feed" 104 | ] 105 | where 106 | email = "duncan@haskell.org (Duncan Coutts)" 107 | 108 | releaseItem :: Users -> URIAuth -> PkgInfo -> [RSS.ItemElem] 109 | releaseItem users host PkgInfo { 110 | pkgInfoId = pkgId 111 | , pkgDesc = pkg 112 | , pkgUploadData = (time, userId) 113 | } = 114 | [ RSS.Title title 115 | , RSS.Link uri 116 | , RSS.Guid True (uriToString id uri "") 117 | , RSS.PubDate time 118 | , RSS.Description desc 119 | ] 120 | where 121 | uri = hackageURI host (packageURL pkgId) 122 | title = unPackageName (packageName pkgId) ++ " " ++ display (packageVersion pkgId) 123 | body = synopsis (packageDescription pkg) 124 | desc = "Added by " ++ display user ++ ", " ++ showTime time ++ "." 125 | ++ if null body then "" else "

" ++ body 126 | user = Users.idToName users userId 127 | 128 | unPackageName :: PackageName -> String 129 | unPackageName (PackageName name) = name 130 | -------------------------------------------------------------------------------- /Distribution/Server/Pages/Template.hs: -------------------------------------------------------------------------------- 1 | -- Common wrapper for HTML pages 2 | module Distribution.Server.Pages.Template 3 | ( hackagePage 4 | , hackagePageWith 5 | , haddockPage 6 | ) where 7 | 8 | import Data.Monoid 9 | import System.FilePath.Posix ( () ) 10 | 11 | import Text.XHtml.Strict hiding ( p, name ) 12 | 13 | -- | Create top-level HTML document by wrapping the Html with boilerplate. 14 | hackagePage :: String -> [Html] -> Html 15 | hackagePage = hackagePageWith [] 16 | 17 | hackagePageWith :: [Html] -> String -> [Html] -> Html 18 | hackagePageWith links heading docs = toHtml [header << docHead, body << docBody] 19 | where 20 | docHead = 21 | thetitle << ("HackageDB: " ++ heading) : 22 | thelink ! [rel "stylesheet", href stylesheetURL, 23 | thetype "text/css"] << noHtml : 24 | -- if NameSearch is enabled 25 | thelink ! [rel "search", href "/opensearch.xml", title "Hackage", 26 | thetype "application/opensearchdescription+xml"] << noHtml : 27 | links 28 | docBody = [thediv ! [theclass "header"] << docHeader, 29 | thediv ! [theclass "content"] << docs] 30 | docHeader = [h1 << hackageTitle, 31 | table ! [theclass "navigation"] << navigation] 32 | hackageTitle = "hackageDB :: [Package]" 33 | navigation = tr << [td << (anchor ! [href url] << lab) | 34 | (lab, url) <- navigationBar] 35 | 36 | -- | Wrapper for pages with haddock styling 37 | haddockPage :: HTML doc => String -> doc -> Html 38 | haddockPage pkgname doc = toHtml [header << docHead, body << doc] 39 | where docHead = [ 40 | meta ! [httpequiv "Content-type", 41 | content "text/html; charset=ISO-8859-1"], 42 | thetitle << ("HackageDB: " ++ pkgname), 43 | haddockThemesLinks, 44 | script ! [thetype "text/javascript", 45 | src haddockJSURL] << noHtml, 46 | script ! [thetype "text/javascript"] << 47 | "window.onload = function() {pageLoad();};"] 48 | 49 | haddockThemesLinks :: Html 50 | haddockThemesLinks = 51 | case haddockThemes of 52 | [] -> mempty 53 | (x:xs) -> 54 | first x `mappend` rest xs 55 | 56 | where 57 | first (name, url) = 58 | thelink ! [rel "stylesheet", thetype "text/css", 59 | href url, title name] << noHtml 60 | rest xs = 61 | mconcat $ flip map xs $ \(name, url) -> 62 | thelink ! [rel "alternate stylesheet", thetype "text/css", 63 | href url, title name] << noHtml 64 | 65 | navigationBar :: [(String, URL)] 66 | navigationBar = 67 | [ ("Introduction", introductionURL) 68 | , ("Packages", pkgListURL) 69 | -- , ("Search", searchURL) 70 | , ("What's new", recentAdditionsURL) 71 | , ("Upload", uploadURL) 72 | , ("User accounts", accountsURL) 73 | , ("Admin", adminURL) 74 | ] 75 | 76 | stylesheetURL :: URL 77 | stylesheetURL = "/hackage.css" 78 | 79 | -- URL of the package list 80 | pkgListURL :: URL 81 | pkgListURL = "/packages/" 82 | 83 | -- URL of the upload form 84 | introductionURL :: URL 85 | introductionURL = "/" 86 | 87 | -- URL of the upload form 88 | uploadURL :: URL 89 | uploadURL = "/upload.html" 90 | 91 | -- URL about user accounts, including the form to change passwords 92 | accountsURL :: URL 93 | accountsURL = "/accounts.html" 94 | 95 | -- URL of the admin front end 96 | adminURL :: URL 97 | adminURL = "/admin.html" 98 | 99 | -- URL of the list of recent additions to the database 100 | recentAdditionsURL :: URL 101 | recentAdditionsURL = "/recent" 102 | 103 | -- URL of haddock specifgic HTML 104 | haddockJSURL :: URL 105 | haddockJSURL = "/haddock/haddock-util.js" 106 | 107 | -- | Haddock themes we have avaliable, name and path 108 | haddockThemes :: [(String, String)] 109 | haddockThemes = 110 | [ ("Ocean", haddockThemesDir "ocean.css") 111 | , ("Classic", haddockThemesDir "xhaddock.css") 112 | ] 113 | 114 | -- | URL directory of haddock theme CSS files 115 | haddockThemesDir :: URL 116 | haddockThemesDir = "/haddock" 117 | -------------------------------------------------------------------------------- /Distribution/Server/Pages/Util.hs: -------------------------------------------------------------------------------- 1 | 2 | module Distribution.Server.Pages.Util 3 | ( hackageNotFound 4 | , hackageError 5 | 6 | , makeInput 7 | , makeCheckbox 8 | ) where 9 | 10 | import Distribution.Server.Pages.Template (hackagePage) 11 | 12 | import Text.XHtml.Strict 13 | 14 | hackageNotFound :: HTML a => a -> Html 15 | hackageNotFound contents 16 | = hackagePage "Not Found" [toHtml contents] 17 | 18 | hackageError :: HTML a => a -> Html 19 | hackageError contents 20 | = hackagePage "Error" [toHtml contents] 21 | 22 | makeInput :: [HtmlAttr] -> String -> String -> [Html] 23 | makeInput attrs fname labelName = [label ! [thefor fname] << labelName, 24 | input ! (attrs ++ [name fname, identifier fname])] 25 | 26 | makeCheckbox :: Bool -> String -> String -> String -> [Html] 27 | makeCheckbox isChecked fname fvalue labelName = [input ! ([thetype "checkbox", name fname, identifier fname, value fvalue] 28 | ++ if isChecked then [checked] else []), 29 | toHtml " ", 30 | label ! [thefor fname] << labelName] 31 | -------------------------------------------------------------------------------- /Distribution/Server/Users/Group.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveDataTypeable, GeneralizedNewtypeDeriving, ExistentialQuantification #-} 2 | module Distribution.Server.Users.Group ( 3 | UserList(..), 4 | UserGroup(..), 5 | GroupDescription(..), 6 | nullDescription, 7 | groupName, 8 | empty, 9 | add, 10 | remove, 11 | member, 12 | enumerate, 13 | fromList, 14 | unions, 15 | queryGroups 16 | ) where 17 | 18 | import Distribution.Server.Users.Types 19 | 20 | import qualified Data.IntSet as IntSet 21 | import Data.Monoid (Monoid) 22 | import Data.SafeCopy (SafeCopy(..), contain) 23 | import Data.Serialize (Serialize) 24 | import qualified Data.Serialize as Serialize 25 | import Data.Typeable (Typeable) 26 | import Control.DeepSeq 27 | 28 | import Prelude hiding (id) 29 | 30 | -- | Some subset of users, eg those allowed to perform some action. 31 | -- 32 | newtype UserList = UserList IntSet.IntSet 33 | deriving (Eq, Monoid, Serialize, Typeable, Show) 34 | 35 | instance SafeCopy UserList where 36 | putCopy = contain . Serialize.put 37 | getCopy = contain Serialize.get 38 | 39 | empty :: UserList 40 | empty = UserList IntSet.empty 41 | 42 | add :: UserId -> UserList -> UserList 43 | add (UserId id) (UserList group) = UserList (IntSet.insert id group) 44 | 45 | remove :: UserId -> UserList -> UserList 46 | remove (UserId id) (UserList group) = UserList (IntSet.delete id group) 47 | 48 | member :: UserId -> UserList -> Bool 49 | member (UserId id) (UserList group) = IntSet.member id group 50 | 51 | enumerate :: UserList -> [UserId] 52 | enumerate (UserList group) = map UserId (IntSet.toList group) 53 | 54 | fromList :: [UserId] -> UserList 55 | fromList ids = UserList $ IntSet.fromList (map (\(UserId uid) -> uid) ids) 56 | 57 | unions :: [UserList] -> UserList 58 | unions groups = UserList (IntSet.unions [ group | UserList group <- groups ]) 59 | 60 | -- | An abstraction over a UserList for dynamically querying and modifying 61 | -- a user group. 62 | -- 63 | -- This structure is not only meant for singleton user groups, but also collections 64 | -- of groups. Some features may provide a UserGroup parametrized by an argument. 65 | -- 66 | data UserGroup = UserGroup { 67 | -- a description of the group for display 68 | groupDesc :: GroupDescription, 69 | -- dynamic querying for its members 70 | queryUserList :: IO UserList, 71 | -- dynamically add a member (does nothing if already exists) 72 | -- creates the group if it didn't exist previously 73 | addUserList :: UserId -> IO (), 74 | -- dynamically remove a member (does nothing if not present) 75 | -- creates the group if it didn't exist previously 76 | removeUserList :: UserId -> IO (), 77 | -- is the user group actually stored in server data? it's possible for 78 | -- a group to exist even if it's empty, and likewise to get a UserGroup 79 | -- that does't exisit *yet* 80 | groupExists :: IO Bool, 81 | -- user groups which can remove from one 82 | canRemoveGroup :: [UserGroup], 83 | -- user groups which can add to this one (use 'fix' to add to self) 84 | canAddGroup :: [UserGroup] 85 | } 86 | 87 | -- | A displayable description for a user group. 88 | -- 89 | -- Given a groupTitle of A and a group entity of Nothing, the group will be 90 | -- called "A"; given a groupTitle of "A" and a groupEntity of Just ("B", 91 | -- Just "C"), the title will be displayed as "A for B". 92 | data GroupDescription = GroupDescription { 93 | groupTitle :: String, 94 | groupEntity :: Maybe (String, Maybe String), 95 | groupPrologue :: String 96 | } 97 | nullDescription :: GroupDescription 98 | nullDescription = GroupDescription { groupTitle = "", groupEntity = Nothing, groupPrologue = "" } 99 | 100 | groupName :: GroupDescription -> String 101 | groupName desc = groupTitle desc ++ maybe "" (\(for, _) -> " for " ++ for) (groupEntity desc) 102 | 103 | queryGroups :: [UserGroup] -> IO UserList 104 | queryGroups = fmap unions . mapM queryUserList 105 | 106 | -- for use in Caches, really... 107 | instance NFData GroupDescription where 108 | rnf (GroupDescription a b c) = rnf a `seq` rnf b `seq` rnf c 109 | 110 | -------------------------------------------------------------------------------- /Distribution/Server/Users/Types.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveDataTypeable, GeneralizedNewtypeDeriving, TemplateHaskell #-} 2 | module Distribution.Server.Users.Types ( 3 | module Distribution.Server.Users.Types, 4 | module Distribution.Server.Framework.AuthTypes 5 | ) where 6 | 7 | import Distribution.Server.Framework.AuthTypes 8 | 9 | import Distribution.Text 10 | ( Text(..) ) 11 | import qualified Distribution.Server.Util.Parse as Parse 12 | import qualified Distribution.Compat.ReadP as Parse 13 | import qualified Text.PrettyPrint as Disp 14 | import qualified Data.Char as Char 15 | 16 | import Data.Serialize (Serialize) 17 | import Control.Applicative ((<$>)) 18 | 19 | import Data.SafeCopy (base, deriveSafeCopy) 20 | import Data.Typeable (Typeable) 21 | 22 | newtype UserId = UserId Int 23 | deriving (Eq, Ord, Show, Serialize, Typeable) 24 | 25 | newtype UserName = UserName String 26 | deriving (Eq, Ord, Show, Serialize, Typeable) 27 | 28 | data UserInfo = UserInfo { 29 | userName :: UserName, 30 | userStatus :: UserStatus 31 | } deriving (Eq, Show, Typeable) 32 | 33 | data UserStatus = Deleted 34 | | Historical 35 | | Active !AccountEnabled UserAuth 36 | deriving (Eq, Show, Typeable) 37 | data AccountEnabled = Enabled | Disabled deriving (Show, Enum, Eq, Typeable) 38 | 39 | isActive, isHistorical :: UserStatus -> Bool 40 | 41 | isActive (Active{}) = True 42 | isActive _ = False 43 | 44 | isHistorical Historical = True 45 | isHistorical _ = False 46 | 47 | data UserAuth = NewUserAuth PasswdHash 48 | | OldUserAuth HtPasswdHash 49 | deriving (Show, Eq, Typeable) 50 | 51 | instance Text UserId where 52 | disp (UserId uid) = Disp.int uid 53 | parse = UserId <$> Parse.int 54 | 55 | instance Text UserName where 56 | disp (UserName name) = Disp.text name 57 | parse = UserName <$> Parse.munch1 Char.isAlphaNum 58 | 59 | $(deriveSafeCopy 0 'base ''UserId) 60 | $(deriveSafeCopy 0 'base ''UserName) 61 | $(deriveSafeCopy 0 'base ''AccountEnabled) 62 | $(deriveSafeCopy 1 'base ''UserAuth) 63 | $(deriveSafeCopy 0 'base ''UserStatus) 64 | $(deriveSafeCopy 0 'base ''UserInfo) 65 | -------------------------------------------------------------------------------- /Distribution/Server/Util/ActionLog.hs: -------------------------------------------------------------------------------- 1 | module Distribution.Server.Util.ActionLog where 2 | 3 | import Distribution.Server.Framework.Error (MessageSpan) 4 | import Data.Set (Set) 5 | import qualified Data.Set as Set 6 | -- other imports.. 7 | 8 | -- Sketch of a datatype to log server actions 9 | type ActionLog a = Set (ActionEntry a) 10 | 11 | data ActionEntry a = ActionEntry { 12 | entryTime :: UTCTime, 13 | entryId :: UserId, 14 | entryData :: a 15 | } 16 | instance Ord (ActionEntry a) where 17 | compare a b = compare (entryTime b) (entryTime a) 18 | 19 | data SomeLog = forall a. SomeLog { 20 | someLog :: ActionLog a, 21 | displayLog :: a -> [MessageSpan] 22 | } 23 | 24 | addEntryNow :: UserId -> a -> ActionLog a -> IO (ActionLog a) 25 | addEntryNow uid datum (ActionLog alog) = do 26 | time <- getCurrentTime 27 | return $ ActionLog $ Set.insert (ActionEntry time uid datum) alog 28 | -------------------------------------------------------------------------------- /Distribution/Server/Util/AsyncVar.hs: -------------------------------------------------------------------------------- 1 | module Distribution.Server.Util.AsyncVar ( 2 | AsyncVar, 3 | new, 4 | read, 5 | write, 6 | modify 7 | ) where 8 | 9 | import Control.Concurrent 10 | import Control.Concurrent.STM 11 | import Control.Exception 12 | 13 | import Prelude hiding (read, catch) 14 | 15 | data AsyncVar state = AsyncVar !(TChan (Either (state -> state) state)) 16 | !(MVar state) 17 | 18 | new :: (state -> ()) -> state -> IO (AsyncVar state) 19 | new force initial = do 20 | () <- evaluate (force initial) 21 | parent <- myThreadId 22 | inChan <- atomically $ newTChan 23 | outVar <- newMVar initial 24 | let loop = do 25 | avail <- readAllAvailable inChan 26 | current <- readMVar outVar 27 | -- we have a series of updates, either incremental or replacement 28 | let value = foldl accum current avail -- note: not foldl' on purpose! 29 | accum x (Left f) = f x 30 | accum _ (Right x') = x' 31 | res <- try $ evaluate (force value) 32 | case res of 33 | Left e -> do throwTo parent (e :: SomeException) 34 | loop 35 | Right _ -> do modifyMVar_ outVar (\_ -> return value) 36 | loop 37 | forkIO loop 38 | return (AsyncVar inChan outVar) 39 | where 40 | -- get a list of all the input states currently queued 41 | readAllAvailable chan = 42 | atomically $ do 43 | x <- readTChan chan -- will block if queue is empty 44 | readAll [x] -- will never block, just gets what's available 45 | where 46 | readAll xs = do 47 | empty <- isEmptyTChan chan 48 | if empty 49 | then return (reverse xs) 50 | else do x <- readTChan chan 51 | readAll (x:xs) 52 | 53 | read :: AsyncVar state -> IO state 54 | read (AsyncVar _ outVar) = readMVar outVar 55 | 56 | write :: AsyncVar state -> state -> IO () 57 | write (AsyncVar inChan _) value = atomically $ writeTChan inChan (Right value) 58 | 59 | modify :: AsyncVar state -> (state -> state) -> IO () 60 | modify (AsyncVar inChan _) func = atomically $ writeTChan inChan (Left func) 61 | -------------------------------------------------------------------------------- /Distribution/Server/Util/ChangeLog.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE PatternGuards #-} 2 | ----------------------------------------------------------------------------- 3 | -- | 4 | -- Module : Distribution.Server.Util.ChangeLog 5 | -- Copyright : (c) Duncan Coutts 2011 6 | -- License : BSD-like 7 | -- 8 | -- Maintainer : duncan@haskell.org 9 | -- Stability : provisional 10 | -- Portability : portable 11 | -- 12 | -- Extra utils for handling change logs 13 | ----------------------------------------------------------------------------- 14 | module Distribution.Server.Util.ChangeLog ( 15 | lookupTarball, 16 | lookupChangeLog 17 | ) where 18 | 19 | import Distribution.Server.Packages.Types 20 | import qualified Distribution.Server.Framework.BlobStorage as BlobStorage 21 | import Distribution.Server.Framework.BlobStorage (BlobStorage) 22 | import Distribution.Server.Util.ServeTarball (readTarIndex) 23 | import qualified Data.TarIndex as TarIndex 24 | 25 | import Distribution.Text (disp) 26 | 27 | import Control.Monad (msum) 28 | import Text.PrettyPrint.HughesPJ (render) 29 | import System.FilePath (()) 30 | 31 | lookupTarball :: BlobStorage -> PkgInfo -> Maybe (IO (FilePath, TarIndex.TarIndex)) 32 | lookupTarball store pkgInfo = 33 | case pkgTarball pkgInfo of 34 | [] -> Nothing 35 | ((tb, _):_) -> Just $ 36 | do let blobId = pkgTarballNoGz tb 37 | fp = BlobStorage.filepath store blobId 38 | index <- readTarIndex fp 39 | return (fp, index) 40 | 41 | lookupChangeLog :: BlobStorage -> PkgInfo -> IO (Either String (FilePath, TarIndex.TarEntryOffset, String)) 42 | lookupChangeLog store pkgInfo = case lookupTarball store pkgInfo of 43 | Nothing -> return $ Left "Could not extract changelog: no tarball exists." 44 | Just io -> 45 | do (fp, index) <- io 46 | case msum $ map (lookupFile index) candidates of 47 | Just (name, offset) -> return $ Right (fp, offset, name) 48 | Nothing -> 49 | do let msg = "No changelog found, files considered: " ++ show candidates 50 | return $ Left msg 51 | where 52 | lookupFile index fname = 53 | do entry <- TarIndex.lookup index fname 54 | case entry of 55 | TarIndex.TarFileEntry offset -> return (fname, offset) 56 | _ -> fail "is a directory" 57 | candidates = 58 | let l = ["ChangeLog", "CHANGELOG", "CHANGE_LOG", "Changelog", "changelog"] 59 | pkgId = render $ disp (pkgInfoId pkgInfo) 60 | in map (pkgId ) $ map (++ ".html") l ++ l 61 | -------------------------------------------------------------------------------- /Distribution/Server/Util/ContentType.hs: -------------------------------------------------------------------------------- 1 | module Distribution.Server.Util.ContentType ( 2 | parseContentAccept 3 | ) where 4 | 5 | import Happstack.Server.Types (ContentType(..)) 6 | 7 | import qualified Text.ParserCombinators.ReadP as Parse 8 | import Data.List (find, sortBy) 9 | import Data.Char (isAlphaNum, isDigit) 10 | import Data.Ord (comparing) 11 | 12 | -- data VaryFormat = Json | Xml | Html | Plain | Other 13 | 14 | -- do some special processing here to fix Webkit's effing issues (and IE's, less so) 15 | -- hackageVaryingAccept :: String -> [VaryFormat] 16 | 17 | -- this just returns a list of content-types sorted by quality preference 18 | parseContentAccept :: String -> [ContentType] 19 | parseContentAccept = process . maybe [] fst . find (null . snd) . Parse.readP_to_S parser 20 | where 21 | process :: [(a, Int)] -> [a] 22 | process = map fst . sortBy (flip (comparing snd)) . filter ((/=0) . snd) 23 | parser :: Parse.ReadP [(ContentType, Int)] 24 | parser = flip Parse.sepBy1 (Parse.char ',') $ do 25 | Parse.skipSpaces 26 | -- a more 'accurate' type than (String, String) 27 | -- might be Maybe (String, Maybe String) 28 | typ <- parseMediaType 29 | Parse.char '/' 30 | subTyp <- parseMediaType 31 | quality <- Parse.option 1000 $ do 32 | Parse.skipSpaces >> Parse.string ";q=" >> Parse.skipSpaces 33 | parseQuality 34 | -- TODO: parse other parameters 35 | return (ContentType {ctType = typ, ctSubtype = subTyp, ctParameters = []}, quality) 36 | parseMediaType = (Parse.char '*' >> return []) Parse.<++ Parse.munch1 (\c -> case c of '-' -> True; '.' -> True; '+' -> True; _ -> isAlphaNum c) 37 | -- other characters technically allowed but never found in the wild: !#$%&^_`|~ 38 | parseQuality :: Parse.ReadP Int -- returns a quality in fixed point (0.75 -> 750) 39 | parseQuality = (Parse.char '1' >> Parse.optional (Parse.char '.' >> Parse.many (Parse.char '0')) >> return 1000) Parse.<++ 40 | (Parse.char '0' >> zeroOption (Parse.char '.' >> zeroOption munch3Digits)) 41 | zeroOption :: Parse.ReadP Int -> Parse.ReadP Int 42 | zeroOption p = p Parse.<++ return 0 43 | munch3Digits :: Parse.ReadP Int 44 | munch3Digits = fmap (\s -> read $ take 3 (s++"00") :: Int) (Parse.munch1 isDigit) 45 | 46 | --application/xml,application/xhtml+xml,text/html;q=0.9,text/plain;q=0.8,image/png,*/*;q=0.5 47 | 48 | -------------------------------------------------------------------------------- /Distribution/Server/Util/Happstack.hs: -------------------------------------------------------------------------------- 1 | 2 | {-| 3 | 4 | Functions and combinators to expose functioanlity buiding 5 | on happstack bit is not really specific to any one area 6 | of Hackage. 7 | 8 | -} 9 | 10 | module Distribution.Server.Util.Happstack ( 11 | rqRealMethod, 12 | methodOverrideHack, 13 | 14 | remainingPath, 15 | remainingPathString, 16 | mime, 17 | consumeRequestBody 18 | ) where 19 | 20 | import Happstack.Server 21 | import qualified Happstack.Server.SURI as SURI 22 | import Happstack.Server.Internal.Types (readM) 23 | import Happstack.Server.Internal.Monads 24 | import qualified Data.Map as Map 25 | import Data.Maybe (fromMaybe) 26 | import Control.Monad.Reader (runReaderT) 27 | import Control.Monad.Trans (MonadIO(..)) 28 | import System.FilePath.Posix (takeExtension, ()) 29 | import Control.Monad (liftM) 30 | 31 | import System.IO.Unsafe (unsafePerformIO) 32 | 33 | 34 | -- | Allows a hidden '_method' field on a form to override the apparent 35 | -- method of a request. Useful until we can standardise on HTML 5. 36 | methodOverrideHack :: MonadIO m => ServerPartT m a -> ServerPartT m a 37 | methodOverrideHack rest 38 | = withDataFn (readM =<< look "_method") $ \mthd -> 39 | localRq (\req -> req { rqMethod = mthd }) rest 40 | 41 | -- | For use with 'methodOverrideHack': tries to report the original method 42 | -- of a request before the hack was applied. 43 | rqRealMethod :: Request -> Method 44 | rqRealMethod rq = fromMaybe (rqMethod rq) $ unsafePerformIO $ runServerPartT_hack rq $ 45 | withDataFn (liftM (not . null) $ lookInputs "_method") $ \mthd_exists -> 46 | return $ if mthd_exists then POST else rqMethod rq 47 | 48 | runServerPartT_hack :: Monad m => Request -> ServerPartT m a -> m (Maybe a) 49 | runServerPartT_hack rq mx 50 | = liftM (\res -> case res of 51 | Nothing -> Nothing 52 | Just (Left _, _) -> Nothing 53 | Just (Right x, _) -> Just x) 54 | (ununWebT (runReaderT (unServerPartT mx) rq)) 55 | 56 | 57 | -- |Passes a list of remaining path segments in the URL. Does not 58 | -- include the query string. This call only fails if the passed in 59 | -- handler fails. 60 | remainingPath :: Monad m => ([String] -> ServerPartT m a) -> ServerPartT m a 61 | remainingPath handle = do 62 | rq <- askRq 63 | localRq (\newRq -> newRq{rqPaths=[]}) $ handle (rqPaths rq) 64 | 65 | -- | Gets the string without altering the request. 66 | remainingPathString :: Monad m => ServerPartT m String 67 | remainingPathString = do 68 | strs <- liftM rqPaths askRq 69 | return $ if null strs then "" else foldr1 () . map SURI.escape $ strs 70 | 71 | -- |Returns a mime-type string based on the extension of the passed in 72 | -- file. 73 | mime :: FilePath -> String 74 | mime x = Map.findWithDefault "text/plain" (drop 1 (takeExtension x)) mimeTypes 75 | 76 | 77 | -- | Get the raw body of a PUT or POST request. 78 | -- 79 | -- Note that for performance reasons, this consumes the data and it cannot be 80 | -- called twice. 81 | -- 82 | consumeRequestBody :: Happstack m => m RqBody 83 | consumeRequestBody = do 84 | mRq <- takeRequestBody =<< askRq 85 | case mRq of 86 | Nothing -> escape $ internalServerError $ toResponse 87 | "consumeRequestBody cannot be called more than once." 88 | Just rq -> return rq 89 | -------------------------------------------------------------------------------- /Distribution/Server/Util/Histogram.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 2 | 3 | module Distribution.Server.Util.Histogram where 4 | 5 | import Data.Map (Map) 6 | import qualified Data.Map as Map 7 | import Data.List (delete, sortBy) 8 | import Data.Ord (comparing) 9 | import Control.DeepSeq 10 | 11 | -- | Histograms are intended to keep track of an integer attribute related 12 | -- to a collection of objects. 13 | data Histogram a = Histogram { 14 | histogram :: Map a Int, 15 | reverseHistogram :: Map Count [a] 16 | } 17 | emptyHistogram :: Histogram a 18 | emptyHistogram = Histogram Map.empty Map.empty 19 | 20 | newtype Count = Count Int deriving (Eq, Show, NFData) 21 | instance Ord Count where 22 | compare (Count a) (Count b) = compare b a 23 | instance NFData a => NFData (Histogram a) where 24 | rnf (Histogram a b) = rnf a `seq` rnf b 25 | 26 | topCounts :: Ord a => Histogram a -> [(a, Int)] 27 | topCounts = concatMap (\(Count c, es) -> map (flip (,) c) es) . Map.toList . reverseHistogram 28 | 29 | topEntries :: Ord a => Histogram a -> [a] 30 | topEntries = concat . Map.elems . reverseHistogram 31 | 32 | getCount :: Ord a => Histogram a -> a -> Int 33 | getCount (Histogram hist _) entry = Map.findWithDefault 0 entry hist 34 | 35 | updateHistogram :: Ord a => a -> Int -> Histogram a -> Histogram a 36 | updateHistogram entry new (Histogram hist rev) = 37 | let old = Map.findWithDefault 0 entry hist 38 | in Histogram 39 | (Map.insert entry new hist) 40 | (Map.alter putInEntry (Count new) . Map.alter takeOutEntry (Count old) $ rev) 41 | where 42 | takeOutEntry Nothing = Nothing 43 | takeOutEntry (Just l) = case delete entry l of 44 | [] -> Nothing 45 | l' -> Just l' 46 | putInEntry Nothing = Just [entry] 47 | putInEntry (Just l) = Just (entry:l) 48 | 49 | constructHistogram :: Ord a => [(a, Int)] -> Histogram a 50 | constructHistogram assoc = Histogram 51 | (Map.fromList assoc) 52 | (Map.fromListWith (++) . map toSingle $ assoc) 53 | where toSingle (entry, c) = (Count c, [entry]) 54 | 55 | sortByCounts :: Ord a => (b -> a) -> Histogram a -> [b] -> [(b, Int)] 56 | sortByCounts entryFunc (Histogram hist _) items = 57 | let modEntry item = (item, Map.findWithDefault 0 (entryFunc item) hist) 58 | in sortBy (comparing snd) $ map modEntry items 59 | 60 | -------------------------------------------------------------------------------- /Distribution/Server/Util/Index.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE PatternGuards #-} 2 | ----------------------------------------------------------------------------- 3 | -- | 4 | -- Module : Distribution.Server.Util.Index 5 | -- Copyright : (c) Duncan Coutts 2008 6 | -- License : BSD-like 7 | -- 8 | -- Maintainer : duncan@haskell.org 9 | -- Stability : provisional 10 | -- Portability : portable 11 | -- 12 | -- Extra utils related to the package indexes. 13 | ----------------------------------------------------------------------------- 14 | module Distribution.Server.Util.Index ( 15 | read, 16 | write, 17 | ) where 18 | 19 | import qualified Codec.Archive.Tar as Tar 20 | ( read, write, Entries(..) ) 21 | import qualified Codec.Archive.Tar.Entry as Tar 22 | ( Entry(..), entryPath, fileEntry, toTarPath ) 23 | 24 | import Distribution.Package 25 | import Distribution.Version 26 | import Distribution.Server.Packages.PackageIndex (PackageIndex) 27 | import qualified Distribution.Server.Packages.PackageIndex as PackageIndex 28 | import Distribution.Text 29 | ( display, simpleParse ) 30 | 31 | import Data.ByteString.Lazy (ByteString) 32 | import System.FilePath.Posix 33 | ( (), (<.>), splitDirectories, normalise ) 34 | import Prelude hiding (read) 35 | 36 | -- | Parse an uncompressed tar repository index file from a 'ByteString'. 37 | -- 38 | -- Takes a function to turn a tar entry into a package 39 | -- 40 | -- This fails only if the tar is corrupted. Any entries not recognized as 41 | -- belonging to a package are ignored. 42 | -- 43 | read :: (PackageIdentifier -> Tar.Entry -> pkg) 44 | -> ByteString 45 | -> Either String [pkg] 46 | read mkPackage indexFileContent = collect [] entries 47 | where 48 | entries = Tar.read indexFileContent 49 | collect es' Tar.Done = Right es' 50 | collect es' (Tar.Next e es) = case entry e of 51 | Just e' -> collect (e':es') es 52 | Nothing -> collect es' es 53 | collect _ (Tar.Fail err) = Left (show err) 54 | 55 | entry e 56 | | [pkgname,versionStr,_] <- splitDirectories (normalise (Tar.entryPath e)) 57 | , Just version <- simpleParse versionStr 58 | , [] <- versionTags version 59 | = let pkgid = PackageIdentifier (PackageName pkgname) version 60 | in Just (mkPackage pkgid e) 61 | entry _ = Nothing 62 | 63 | -- | Create an uncompressed tar repository index file as a 'ByteString'. 64 | -- 65 | -- Takes a couple functions to turn a package into a tar entry. Extra 66 | -- entries are also accepted. 67 | -- 68 | write :: Package pkg 69 | => (pkg -> ByteString) 70 | -> (pkg -> Tar.Entry -> Tar.Entry) 71 | -> [Tar.Entry] 72 | -> PackageIndex pkg 73 | -> ByteString 74 | write externalPackageRep updateEntry extras = 75 | Tar.write . (extras++) . map entry . PackageIndex.allPackages 76 | where 77 | entry pkg = updateEntry pkg 78 | . Tar.fileEntry tarPath 79 | $ externalPackageRep pkg 80 | where 81 | Right tarPath = Tar.toTarPath False fileName 82 | PackageName name = packageName pkg 83 | fileName = name display (packageVersion pkg) 84 | name <.> "cabal" 85 | 86 | -------------------------------------------------------------------------------- /Distribution/Server/Util/Merge.hs: -------------------------------------------------------------------------------- 1 | module Distribution.Server.Util.Merge where 2 | 3 | import Data.Map 4 | 5 | 6 | data MergeResult a b = OnlyInLeft a | InBoth a b | OnlyInRight b 7 | 8 | mergeBy :: (a -> b -> Ordering) -> [a] -> [b] -> [MergeResult a b] 9 | mergeBy cmp = merge 10 | where 11 | merge [] ys = [ OnlyInRight y | y <- ys] 12 | merge xs [] = [ OnlyInLeft x | x <- xs] 13 | merge (x:xs) (y:ys) = 14 | case x `cmp` y of 15 | GT -> OnlyInRight y : merge (x:xs) ys 16 | EQ -> InBoth x y : merge xs ys 17 | LT -> OnlyInLeft x : merge xs (y:ys) 18 | 19 | mergeMaps :: Ord k => Map k a -> Map k b -> Map k (MergeResult a b) 20 | mergeMaps m1 m2 = unionWith (\(OnlyInLeft a) (OnlyInRight b) -> InBoth a b) (fmap OnlyInLeft m1) (fmap OnlyInRight m2) 21 | -------------------------------------------------------------------------------- /Distribution/Server/Util/NameIndex.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveDataTypeable, TemplateHaskell, 2 | FlexibleInstances, FlexibleContexts, MultiParamTypeClasses #-} 3 | -- TypeOperators, TypeSynonymInstances, TypeFamilies 4 | 5 | module Distribution.Server.Util.NameIndex where 6 | 7 | import Data.Map (Map) 8 | import Data.Typeable (Typeable) 9 | import qualified Data.Map as Map 10 | import Data.Set (Set) 11 | import qualified Data.Set as Set 12 | import Data.Char (toLower) 13 | import Data.List (unfoldr, foldl') 14 | import Data.Maybe (maybeToList) 15 | import Control.DeepSeq 16 | import Data.SafeCopy 17 | -- | Case-insensitive name search. This is meant to be an enhanced set of 18 | -- names, not a full text search. It's also meant to be a sort of a short-term 19 | -- solution for name suggestion searches; e.g., package searches should also 20 | -- consider the tagline of a package. 21 | data NameIndex = NameIndex { 22 | -- | This is the mapping from case-insensitive search term -> name. 23 | nameIndex :: Map String (Set String), 24 | -- | This is the set of names. 25 | storedNamesIndex :: Set String, 26 | -- | This is the specification of the type of generator, mainly here because 27 | -- functions can't be serialized. Just str means to break on any char in 28 | -- str (breakGenerator); Nothing is defaultGenerator. 29 | nameGenType :: Maybe [Char], 30 | -- | This is the generator of search terms from names. 31 | nameSearchGenerator :: String -> [String] 32 | } deriving (Typeable) 33 | 34 | emptyNameIndex :: Maybe [Char] -> NameIndex 35 | emptyNameIndex gen = NameIndex Map.empty Set.empty gen $ case gen of 36 | Nothing -> defaultGenerator 37 | Just st -> breakGenerator st 38 | 39 | defaultGenerator :: String -> [String] 40 | defaultGenerator name = [name] 41 | 42 | breakGenerator :: [Char] -> String -> [String] 43 | breakGenerator breakStr name = name:unfoldr unfoldName name 44 | where unfoldName str = case break (`elem` breakStr) str of 45 | ([], _) -> Nothing 46 | (_, []) -> Nothing 47 | (_, _:str') -> Just (str', str') 48 | 49 | constructIndex :: [String] -> Maybe [Char] -> NameIndex 50 | constructIndex strs gen = foldl' (flip addName) (emptyNameIndex gen) strs 51 | 52 | addName :: String -> NameIndex -> NameIndex 53 | addName caseName (NameIndex index stored gen' gen) = 54 | let name = map toLower caseName 55 | nameSet = Set.singleton caseName 56 | forName = Map.fromList $ map (\term -> (term, nameSet)) (gen name) 57 | in NameIndex (Map.unionWith Set.union index forName) 58 | (Set.insert caseName stored) gen' gen 59 | 60 | deleteName :: String -> NameIndex -> NameIndex 61 | deleteName caseName (NameIndex index stored gen' gen) = 62 | let name = map toLower caseName 63 | nameSet = Set.singleton caseName 64 | forName = Map.fromList $ map (\term -> (term, nameSet)) (gen name) 65 | in NameIndex (Map.differenceWith (\a b -> keepSet $ Set.difference a b) index forName) 66 | (Set.delete caseName stored) gen' gen 67 | where keepSet s = if Set.null s then Nothing else Just s 68 | 69 | lookupName :: String -> NameIndex -> Set String 70 | lookupName caseName (NameIndex index _ _ _) = 71 | Map.findWithDefault Set.empty (map toLower caseName) index 72 | 73 | lookupPrefix :: String -> NameIndex -> Set String 74 | lookupPrefix caseName (NameIndex index _ _ _) = 75 | let name = map toLower caseName 76 | (_, mentry, startTree) = Map.splitLookup name index 77 | -- the idea is, select all names in the range [name, mapLast succ name) 78 | -- an alternate idea would just be to takeWhile (`isPrefixOf` name) 79 | (totalTree, _, _) = Map.splitLookup (mapLast succ name) startTree 80 | nameSets = maybeToList mentry ++ Map.elems totalTree 81 | in Set.unions nameSets 82 | 83 | takeSetPrefix :: String -> Set String -> Set String 84 | takeSetPrefix name strs = 85 | let (_, present, startSet) = Set.splitMember name strs 86 | (totalSet, _, _) = Set.splitMember (mapLast succ name) startSet 87 | in (if present then Set.insert name else id) totalSet 88 | 89 | -- | Map only the last element of a list 90 | mapLast :: (a -> a) -> [a] -> [a] 91 | mapLast f (x:[]) = f x:[] 92 | mapLast f (x:xs) = x:mapLast f xs 93 | mapLast _ [] = [] 94 | 95 | -- store arguments which can be sent to constructIndex :: [String] -> Maybe [Char] -> NameIndex 96 | instance SafeCopy NameIndex where 97 | putCopy index = contain $ safePut (nameGenType index) >> safePut (storedNamesIndex index) 98 | getCopy = contain $ do 99 | gen <- safeGet 100 | index <- safeGet 101 | return $ constructIndex (Set.toList index) gen 102 | 103 | instance NFData NameIndex where 104 | rnf (NameIndex a b _ _) = rnf a `seq` rnf b 105 | -------------------------------------------------------------------------------- /Distribution/Server/Util/Parse.hs: -------------------------------------------------------------------------------- 1 | module Distribution.Server.Util.Parse ( 2 | int, unpackUTF8 3 | ) where 4 | 5 | import qualified Distribution.Compat.ReadP as Parse 6 | import Distribution.Simple.Utils ( fromUTF8 ) 7 | 8 | import qualified Data.ByteString.Lazy.Char8 as BS 9 | import qualified Data.Char as Char 10 | 11 | -- | Parse a positive integer. No leading @0@'s allowed. 12 | -- 13 | int :: Parse.ReadP r Int 14 | int = do 15 | first <- Parse.satisfy Char.isDigit 16 | if first == '0' 17 | then return 0 18 | else do rest <- Parse.munch Char.isDigit 19 | return (read (first : rest)) 20 | 21 | -- | Ignore a Unicode byte order mark (BOM) at the beginning of the input 22 | -- 23 | -- (Also in Distribution.Simple.Utils, but not exported) 24 | ignoreBOM :: String -> String 25 | ignoreBOM ('\xFEFF':string) = string 26 | ignoreBOM string = string 27 | 28 | unpackUTF8 :: BS.ByteString -> String 29 | unpackUTF8 = ignoreBOM . fromUTF8 . BS.unpack 30 | -------------------------------------------------------------------------------- /Distribution/Server/Util/ServeTarball.hs: -------------------------------------------------------------------------------- 1 | ----------------------------------------------------------------------------- 2 | -- | 3 | -- Module : Distribution.Server.Util.ServeTarball 4 | -- Copyright : (c) 2008 David Himmelstrup 5 | -- (c) 2009 Antoine Latter 6 | -- License : BSD-like 7 | -- 8 | -- Maintainer : duncan@haskell.org 9 | -- Stability : provisional 10 | -- Portability : portable 11 | -- 12 | -- 13 | ----------------------------------------------------------------------------- 14 | module Distribution.Server.Util.ServeTarball 15 | ( serveTarball 16 | , serveTarEntry 17 | , readTarIndex 18 | ) where 19 | 20 | import Happstack.Server.Types 21 | import Happstack.Server.Monads 22 | import Happstack.Server.Routing (methodOnly) 23 | import Happstack.Server.Response 24 | import Happstack.Server.FileServe as Happstack (mimeTypes) 25 | import Distribution.Server.Util.Happstack (remainingPath) 26 | import Distribution.Server.Pages.Template (hackagePage) 27 | 28 | import qualified Codec.Archive.Tar as Tar 29 | import qualified Codec.Archive.Tar.Entry as Tar 30 | import qualified Data.TarIndex as TarIndex 31 | import Data.TarIndex (TarIndex) 32 | 33 | import qualified Text.XHtml.Strict as XHtml 34 | import qualified Data.ByteString.Lazy as BS 35 | import qualified Data.Map as Map 36 | import System.FilePath 37 | import Control.Exception (evaluate) 38 | import Control.Monad.Trans (MonadIO, liftIO) 39 | import Control.Monad (msum, mzero) 40 | import System.IO 41 | 42 | 43 | -- | Server the contents of a tar file 44 | -- file. This is not a sustainable implementation, 45 | -- but it gives us something to test with. 46 | serveTarball :: MonadIO m 47 | => [FilePath] -- indices 48 | -> FilePath -- prefix of paths in tar 49 | -> FilePath -- tarball 50 | -> TarIndex -- index for tarball 51 | -> ServerPartT m Response 52 | serveTarball indices offset tarball tarIndex = do 53 | action GET $ remainingPath $ \paths -> do 54 | 55 | -- first we come up with the set of paths in the tarball that 56 | -- would match our request 57 | let validPaths :: [FilePath] 58 | validPaths = (joinPath $ offset:paths) : map f indices 59 | f index = joinPath $ offset:paths ++ [index] 60 | 61 | msum $ concat 62 | [ serveFiles validPaths 63 | , serveDirs paths validPaths 64 | ] 65 | 66 | where serveFiles paths 67 | = flip map paths $ \path -> 68 | case TarIndex.lookup tarIndex path of 69 | Just (TarIndex.TarFileEntry off) 70 | -> do 71 | tfe <- liftIO $ serveTarEntry tarball off path 72 | ok (toResponse tfe) 73 | _ -> mzero 74 | 75 | action act m = methodOnly act >> m 76 | 77 | serveDirs prefix paths 78 | = flip map paths $ \path -> 79 | case TarIndex.lookup tarIndex path of 80 | Just (TarIndex.TarDir fs) 81 | -> do ok $ toResponse $ renderDirIndex prefix fs 82 | _ -> mzero 83 | 84 | renderDirIndex :: [FilePath] -> [FilePath] -> XHtml.Html 85 | renderDirIndex paths entries = hackagePage "Directory Listing" 86 | [ (XHtml.anchor XHtml.! [XHtml.href (mk_prefix e)] XHtml.<< e) 87 | XHtml.+++ XHtml.br 88 | | e <- entries ] 89 | where -- We need to munge the paths to match the path prefix: 90 | mk_prefix | null paths = id 91 | | otherwise = (last paths ) 92 | 93 | serveTarEntry :: FilePath -> Int -> FilePath -> IO Response 94 | serveTarEntry tarfile off fname = do 95 | htar <- openFile tarfile ReadMode 96 | hSeek htar AbsoluteSeek (fromIntegral (off * 512)) 97 | header <- BS.hGet htar 512 98 | case Tar.read header of 99 | (Tar.Next Tar.Entry{Tar.entryContent = Tar.NormalFile _ size} _) -> do 100 | body <- BS.hGet htar (fromIntegral size) 101 | let extension = case takeExtension fname of 102 | ('.':ext) -> ext 103 | ext -> ext 104 | mimeType = Map.findWithDefault "text/plain" extension mimeTypes' 105 | response = ((setHeader "Content-Length" (show size)) . 106 | (setHeader "Content-Type" mimeType)) $ 107 | resultBS 200 body 108 | return response 109 | _ -> fail "oh noes!!" 110 | 111 | -- | Extended mapping from file extension to mime type 112 | mimeTypes' :: Map.Map String String 113 | mimeTypes' = Happstack.mimeTypes `Map.union` Map.fromList 114 | [("xhtml", "application/xhtml+xml")] 115 | 116 | readTarIndex :: FilePath -> IO TarIndex 117 | readTarIndex file = do 118 | tar <- BS.readFile file 119 | let entries = Tar.read tar 120 | case extractInfo entries of 121 | Just info -> evaluate (TarIndex.construct info) 122 | Nothing -> fail "bad tar file" 123 | 124 | type Block = Int 125 | 126 | extractInfo :: Tar.Entries e -> Maybe [(FilePath, Block)] 127 | extractInfo = go 0 [] 128 | where 129 | go _ es' (Tar.Done) = Just es' 130 | go _ _ (Tar.Fail _) = Nothing 131 | go n es' (Tar.Next e es) = go n' ((Tar.entryPath e, n) : es') es 132 | where 133 | n' = n + 1 134 | + case Tar.entryContent e of 135 | Tar.NormalFile _ size -> blocks size 136 | Tar.OtherEntryType _ _ size -> blocks size 137 | _ -> 0 138 | blocks s = 1 + ((fromIntegral s - 1) `div` 512) 139 | 140 | -------------------------------------------------------------------------------- /Distribution/Server/Util/TarIndex.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell, DeriveDataTypeable, TypeFamilies, TemplateHaskell, 2 | MultiParamTypeClasses, FlexibleInstances, FlexibleContexts #-} 3 | 4 | -- This is presently unused: features provide their own BlobId-to-TarIndex 5 | -- mappings. 6 | 7 | module Distribution.Server.Util.TarIndex 8 | where 9 | 10 | import Control.Applicative ((<$>)) 11 | import Control.Monad.Reader.Class (asks) 12 | import Control.Monad.State.Class (put, modify) 13 | import qualified Data.Map as Map 14 | 15 | import Data.Acid (makeAcidic) 16 | import Data.SafeCopy (base, deriveSafeCopy) 17 | import Data.TarIndex (TarIndex) 18 | 19 | import Distribution.Server.Packages.State() 20 | import Distribution.Server.Framework.BlobStorage (BlobId) 21 | 22 | data TarIndexMap = M {indexMap :: Map.Map BlobId TarIndex} 23 | deriving (Typeable, Show) 24 | 25 | addIndex :: BlobId -> TarIndex -> Update TarIndexMap () 26 | addIndex blob index = modify $ insertTarIndex blob index 27 | 28 | insertTarIndex :: BlobId -> TarIndex -> TarIndexMap -> TarIndexMap 29 | insertTarIndex blob index (M state) = M (Map.insert blob index state) 30 | 31 | dropIndex :: BlobId -> Update TarIndexMap () 32 | dropIndex blob = modify $ \(M state) -> M (Map.delete blob state) 33 | 34 | lookupIndex :: BlobId -> Query TarIndexMap (Maybe TarIndex) 35 | lookupIndex blob = Map.lookup blob <$> asks indexMap 36 | 37 | replaceTarIndexMap :: TarIndexMap -> Update TarIndexMap () 38 | replaceTarIndexMap = put 39 | 40 | $(deriveSafeCopy 0 'base ''TarIndexMap) 41 | 42 | initialTarIndexMap :: TarIndexMap 43 | initialTarIndexMap = emptyTarIndex 44 | 45 | emptyTarIndex :: TarIndexMap 46 | emptyTarIndex = M Map.empty 47 | 48 | 49 | $(makeAcidic ''TarIndexMap 50 | [ 'addIndex 51 | , 'dropIndex 52 | , 'lookupIndex 53 | , 'replaceTarIndexMap 54 | ] 55 | ) 56 | -------------------------------------------------------------------------------- /Distribution/Server/Util/TextSearch.hs: -------------------------------------------------------------------------------- 1 | module Distribution.Server.Util.TextSearch ( 2 | TextSearch(..), 3 | constructTextIndex, 4 | searchText 5 | ) where 6 | 7 | import Data.ByteString.Char8 (ByteString) 8 | import qualified Data.ByteString.Char8 as BS 9 | import Data.ByteString.Search 10 | import Data.Map (Map) 11 | import qualified Data.Map as Map 12 | import Data.Char 13 | import Data.Maybe (catMaybes) 14 | 15 | -- Basic full text search. This works best when there are plenty of entries 16 | -- and all of them are short. I'd use something like Hayoo here, but there's 17 | -- no easy way to integrate it into the site. 18 | -- 19 | -- At present this uses Bayer-Moore. Something with multiple search keys 20 | -- might be more flexible. Or, even better, a Lucene-like engine. 21 | data TextSearch = TextSearch { 22 | fullText :: ByteString, 23 | textIndex :: Map Int (String, String) 24 | } deriving Show 25 | 26 | constructTextIndex :: [(String, String)] -> TextSearch 27 | constructTextIndex strs = case go strs 0 of 28 | (bs, texts) -> TextSearch (BS.concat bs) (Map.fromList texts) 29 | where 30 | go :: [(String, String)] -> Int -> ([ByteString], [(Int, (String, String))]) 31 | go [] _ = ([], []) 32 | go (pair@(_, text):xs) pos = 33 | let text' = BS.pack $ "\0" ++ stripText text 34 | in case go xs (BS.length text' + pos) of 35 | ~(bs, texts) -> (text':bs, (pos, pair):texts) 36 | 37 | stripText :: String -> String 38 | stripText = map toLower . filter (\c -> isSpace c || isAlphaNum c) 39 | 40 | searchText :: TextSearch -> String -> [(String, String)] 41 | searchText (TextSearch theText theIndex) str = 42 | Map.toList . Map.fromAscListWith const 43 | . catMaybes . map (\i -> getIndexEntry (fromIntegral i) theIndex) 44 | $ nonOverlappingIndices (BS.pack $ stripText str) theText 45 | 46 | -- TODO: offset might be useful for determining whether the match was whole-word 47 | -- or no 48 | getIndexEntry :: Int -> Map Int a -> Maybe a 49 | getIndexEntry index theIndex = case Map.splitLookup index theIndex of 50 | (_, Just entry, _) -> Just entry 51 | (beforeMap, _, afterMap) -> case (Map.null beforeMap, Map.null afterMap) of 52 | (True, True) -> Nothing 53 | (True, False) -> Just $ snd $ Map.findMin afterMap 54 | (False, _) -> Just $ snd $ Map.findMax beforeMap 55 | 56 | -------------------------------------------------------------------------------- /Distribution/Server/Util/TimeLogger.hs: -------------------------------------------------------------------------------- 1 | module Distribution.Server.Util.TimeLogger where 2 | 3 | import Control.Concurrent 4 | import Happstack.Server 5 | import Control.Monad.Trans (liftIO) 6 | import System.IO 7 | import Control.Monad (forever, when) 8 | import Data.Time.Clock (getCurrentTime, diffUTCTime) 9 | import qualified Happstack.Util.Concurrent as HappsLoad 10 | import qualified Data.ByteString.Lazy as BS 11 | 12 | -- Logging to determine the performance of various pages 13 | setUpLog :: IO (Chan String) 14 | setUpLog = do 15 | ch <- newChan 16 | HappsLoad.fork $ withFile "times" AppendMode $ \h -> do 17 | hSetBuffering h LineBuffering 18 | forever $ hPutStrLn h =<< readChan ch 19 | return ch 20 | 21 | -- An adaptor for impl in Distribution.Server. It evaluates the response 22 | -- and returns it, adding a log entry in the progress. By "evaluate" 23 | -- I mean that it forces the length of the response string, which 24 | -- should at least also force the computation tree of the response. 25 | timeLog :: Chan String -> ServerPart Response -> ServerPart Response 26 | timeLog ch sres = do 27 | t <- liftIO $ getCurrentTime 28 | res <- sres 29 | case res of 30 | Response{} -> do 31 | when (rsfContentLength $ rsFlags res) $ do 32 | let resl = BS.length $ rsBody res 33 | t2 <- resl `seq` liftIO getCurrentTime 34 | uri <- fmap rqUri askRq 35 | let str = unwords [uri, show resl, show $ diffUTCTime t2 t] 36 | liftIO (writeChan ch str) 37 | return res 38 | _ -> return res 39 | 40 | 41 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright 2008, Duncan Coutts and David Himmelstrup. 2 | All rights reserved. 3 | 4 | Redistribution and use in source and binary forms, with or without 5 | modification, are permitted provided that the following conditions are met: 6 | 7 | - Redistributions of source code must retain the above copyright notice, 8 | this list of conditions and the following disclaimer. 9 | 10 | - Redistributions in binary form must reproduce the above copyright notice, 11 | this list of conditions and the following disclaimer in the documentation 12 | and/or other materials provided with the distribution. 13 | 14 | - The names of the contributors may not be used to endorse or promote 15 | products derived from this software without specific prior written 16 | permission. 17 | 18 | THIS SOFTWARE IS PROVIDED BY "AS IS" AND ANY EXPRESS OR IMPLIED 19 | WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF 20 | MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN 21 | NO EVENT SHALL THE CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, 22 | INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, 23 | BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF 24 | USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON 25 | ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 26 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 27 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 28 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | This is a copy of [the hackage2 codebase found here](http://code.haskell.org/hackage-server/), 2 | converted to make it more convenient for github users to hack on it. The 3 | repository conversion was done with 4 | [darcs-fastconvert](http://hackage.haskell.org/package/darcs-fastconvert). I'll 5 | appreciate if someone better versed in darcs than I is willing to help push 6 | any changes made back upstream to avoid getting things out of sync. 7 | 8 | A few minor changes have been made to get it to compile on my system. Can't 9 | promise it will build on yours, though. :] 10 | 11 | -------------------------------------------------------------------------------- /TODO: -------------------------------------------------------------------------------- 1 | General: 2 | * Error handling style is horribly verbose. 3 | We need a nice monadic style where we can fail with e.g. internal server 4 | errors without propagating Either blah blah all over the place. 5 | See for example how we cannot currently abstract over takeRequestBody. 6 | 7 | Backup: 8 | * Implement import for Documentation 9 | * Reduce space for import (enable garbage collection of more things) 10 | * Bulk import should create tags and maintainer information automatically 11 | * Create backup tarballs on a running server 12 | * Create backup tarballs from selected features so others can set up their own Hackages 13 | 14 | Users: 15 | * Expose renaming for the Users feature 16 | * Expose user id information for mirrors and e.g. merging accounts with totalNameMap 17 | * Decide on user registration policy and implement as a new feature (currently, admins register accounts) 18 | 19 | Other features: 20 | * Improve text search, producing more intuitive results in less time 21 | * Bring BuildReports, Distro up to par with other features 22 | 23 | Feature views: 24 | * Implement JSON views for all the features 25 | * Split up the HTML feature into smaller subpages 26 | * Switch to BlazeHTML 27 | * Use the JSON functionality in-browser for Ajax 28 | 29 | HTTP principles: 30 | * DELETE, PUT, and (in some cases) POST should not redirect, but rather return 31 | a document indicating the location of the new resource, if necessary, or other 32 | cues to continue browsing. 33 | 34 | Miscellaneous 35 | * Catch exceptions for asynchronous variables and hooks 36 | * Add more links to [ErrorMessage]s throughout the application, particularly with authentication 37 | * Decide how to coordinate a switchover basic to digest auth 38 | * Send etag and last modified times, if possible 39 | 40 | -------------------------------------------------------------------------------- /static/accounts.html: -------------------------------------------------------------------------------- 1 | 2 | HackageDB: User accounts 3 | 4 | 5 |

6 |

hackageDB :: [Package]

7 | 8 | 9 | 10 | 11 | 12 | 13 | 14 | 15 | 16 | 17 |
IntroductionPackagesWhat's newUploadUser accountsAdmin
18 |
19 | 20 |

User accounts

21 |

Most of the functions of the HackageDB web interface 22 | (including browsing and checking packages) are available to all. 23 | However, uploading packages requires a HackageDB username and password. 24 | 25 |

The policy for getting an account is still up in the air. Meanwhile, you 26 | can peruse the small list of users (no accounts have 27 | been imported from the main Hackage). You can also 28 | register a new user account. 29 | 30 |

Passwords are stored encrypted, so if you forget yours we can't recover it, 31 | but will need to assign a new one. Just ask. 32 | 33 | -------------------------------------------------------------------------------- /static/admin.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | HackageDB: user administartion 5 | 6 | 7 | 8 | 9 |

10 |

hackageDB :: [Package]

11 | 12 | 13 | 14 | 15 | 16 | 17 | 18 | 19 | 20 |
IntroductionPackagesWhat's newUploadUser accountsAdmin
21 |
22 | 23 |
24 |

Admin front-end

25 | 26 | 32 | 33 | 67 | 68 |
69 | 70 | -------------------------------------------------------------------------------- /static/built-with-cabal.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/isomorphism/hackage2/4f68f312a31924c18561a4e37c7806027d3ab154/static/built-with-cabal.png -------------------------------------------------------------------------------- /static/cabal-tiny.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/isomorphism/hackage2/4f68f312a31924c18561a4e37c7806027d3ab154/static/cabal-tiny.png -------------------------------------------------------------------------------- /static/favicon.ico: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/isomorphism/hackage2/4f68f312a31924c18561a4e37c7806027d3ab154/static/favicon.ico -------------------------------------------------------------------------------- /static/hackage.css: -------------------------------------------------------------------------------- 1 | body { 2 | font-family: sans-serif; 3 | color: black; background: white; 4 | } 5 | div.header { 6 | border: thin solid black; 7 | } 8 | h1 { 9 | text-align: center; 10 | margin-top: 0.6ex; 11 | margin-bottom: 0.9ex; 12 | font-weight: normal; 13 | color: #888; 14 | } 15 | h2 { 16 | margin: 0.83em 0px 0.2em 0px; 17 | border-bottom: thin gray solid 18 | } 19 | table.navigation { 20 | background: #f1f1f1; 21 | border-top: thin solid black; 22 | width: 100%; 23 | } 24 | table.navigation td { 25 | text-align: center; 26 | } 27 | .floatright { 28 | float: right; 29 | margin-right: 0; 30 | } 31 | .floatright a:link img { border-width: 1px; } 32 | .floatright a:visited img { border-width: 1px; } 33 | .floatright a:active img { border-width: 1px; } 34 | .toc { 35 | font-size: smaller; 36 | padding: 3px; 37 | background: #f1f1f1; 38 | border: thin solid black; 39 | } 40 | .notification { 41 | font-size: smaller; 42 | padding: 3px; 43 | background: #cccccc; 44 | border: thin solid black; 45 | } 46 | h3.category { 47 | color: #008; background-color: #e0f0ff; 48 | padding: 2px 3px; 49 | margin: 0; 50 | } 51 | ul.packages { 52 | margin: 1ex 0; 53 | list-style-image: url(/cabal-tiny.png); 54 | list-style-type: circle; 55 | } 56 | table.properties { 57 | width: 100%; 58 | } 59 | tr.odd { background: #e2e2e2 } 60 | tr.even { background: #f1f1f1 } 61 | th.horizontal { 62 | vertical-align: top; 63 | text-align: left; 64 | } 65 | form.box { 66 | background-color: #f8e8c1; 67 | padding: 0.4ex 0.4em; 68 | border-style: solid; 69 | border-width: 2px; 70 | border-color: #f4f3f2 #797876 #797876 #f4f3f2; 71 | margin: 1.5ex 0; 72 | } 73 | strong.warning { color: red; } 74 | 75 | a:link { color: #0000e0; text-decoration: none } 76 | a:visited { color: #0000a0; text-decoration: none } 77 | a:hover { background-color: #e0e0ff; text-decoration: none } 78 | 79 | .unpreferred { color: green !important; } 80 | .deprecated { color: gray !important; text-decoration: line-through; } 81 | 82 | 83 | -------------------------------------------------------------------------------- /static/hackage.html: -------------------------------------------------------------------------------- 1 | 2 | HackageDB: introduction 3 | 4 | 5 |
6 |

hackageDB :: [Package]

7 | 8 | 9 | 10 | 11 | 12 | 13 | 14 | 15 | 16 | 17 |
IntroductionPackagesWhat's newUploadUser accountsAdmin
18 |
19 | 20 |
21 |

About HackageDB

22 | 23 |

HackageDB is a collection of released 24 | Haskell packages. 25 | Each package is in the Cabal format, 26 | a standard way of packaging Haskell source code that makes it easy to build 27 | and install. 28 | (HackageDB and Cabal are components of a broader Haskell infrastructure effort 29 | called Hackage.) 30 | These pages are a basic web interface to the Hackage package database. 31 | 32 |

This isn't the official HackageDB. It's an in-progress 33 | rewrite of the server using the happstack web 34 | framework. 35 | 36 |

Finding packages

37 | 38 |

The Packages link above lists the available packages 39 | and provides a full text search of the package pages (via Google), 40 | while What's new lists recent additions (also available 41 | as an RSS feed). You can also do a simple text 42 | search of package descriptions: 43 | 44 |

45 | 46 |

There are a few other package indices: 47 |

56 | 57 |

See How to install a Cabal package for instructions on installing the packages you find here. 58 | 59 |

Releasing packages through HackageDB

60 |

To upload your own releases, you'll first need to package them as Cabal 61 | source packages. 62 | See How to create a Haskell package 63 | for a tutorial. 64 | You can check and upload your package using the Upload link above, 65 | though you'll need a HackageDB username and password. 66 | 67 |

Getting the raw data

68 | 71 | 72 |

Development

73 |

See the 74 | HackageDB wiki page. 75 | There is also a document in progress summarizing the architecture of the new hackage-server. Check out the code yourself: 76 | 77 | 

darcs get http://code.haskell.org/hackage-server
78 | 79 | We'd like to make it as simple as possible for anyone to set up a Hackage server. 80 |
81 | -------------------------------------------------------------------------------- /static/haddock/haskell_icon.gif: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/isomorphism/hackage2/4f68f312a31924c18561a4e37c7806027d3ab154/static/haddock/haskell_icon.gif -------------------------------------------------------------------------------- /static/haddock/hslogo-16.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/isomorphism/hackage2/4f68f312a31924c18561a4e37c7806027d3ab154/static/haddock/hslogo-16.png -------------------------------------------------------------------------------- /static/haddock/minus.gif: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/isomorphism/hackage2/4f68f312a31924c18561a4e37c7806027d3ab154/static/haddock/minus.gif -------------------------------------------------------------------------------- /static/haddock/plus.gif: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/isomorphism/hackage2/4f68f312a31924c18561a4e37c7806027d3ab154/static/haddock/plus.gif -------------------------------------------------------------------------------- /static/haddock/synopsis.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/isomorphism/hackage2/4f68f312a31924c18561a4e37c7806027d3ab154/static/haddock/synopsis.png -------------------------------------------------------------------------------- /static/upload.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | HackageDB: Uploading packages and package candidates 5 | 6 | 7 | 8 |
9 |

hackageDB :: [Package]

10 | 11 | 12 | 13 | 14 | 15 | 16 | 17 | 18 | 19 |
IntroductionPackagesWhat's newUploadUser accountsAdmin
20 |
21 | 22 |
23 |

Uploading packages and package candidates

24 |

Uploading a package puts it in the main package index 25 | so that anyone can download it and view information about it. You can only 26 | upload a package version once, so try to get it right the first time! 27 | 28 |

You can also upload a package candidate 29 | to preview the package page, view any warnings or possible errors you might 30 | encounter, and let others install it before publishing it to the main index. 31 | (Note: you can view these warnings with 'cabal check'.) You can have multiple 32 | candidates for each package at the same time so long as they each have different 33 | versions. Finally, you can publish a candidate to the main index if it's not 34 | there already. 35 | 36 |

If you upload a package or package candidate and no other versions exist 37 | in the package database, you become part of the maintainer group for that 38 | package, and you can add other maintainers if you wish. If a maintainer group 39 | exists for a package, only its members can upload new versions of that package. 40 | 41 |

If there is no maintainer, the uploader can remove themselves from the group, 42 | and a package trustee can add anyone who wishes 43 | to assume the responsibility. The Maintainer field of the Cabal file should be 44 | None in this case. If a package is being maintained, any release not approved 45 | and supported by the maintainer should use a different package name. Then use 46 | the Maintainer field as above either to commit to supporting the fork 47 | yourself or to mark it as unsupported. 48 | 49 |

Note that all of the above is a makeshift upload policy based on the features 50 | available in the newer hackage-server. The Maintainer field has its uses, 51 | as does maintainer user groups. The libraries mailing list should probably 52 | determine the best approach for this. 53 | 54 |

Upload forms

55 |

Some last formalities: to upload a package, you'll need a HackageDB 56 | username and password. (Alternatively, there's a 57 | command-line interface via cabal-install, which also needs the same username 58 | and password.) 59 | 60 |

Packages must be in the form produced by Cabal's 61 | sdist command: 62 | a gzipped tar file package-version.tar.gz 63 | comprising a directory package-version containing a package 64 | of that name and version, including package.cabal. 65 | See the notes at the bottom of the page. 66 | 67 |

68 | 69 | 70 |

Notes

71 |
    72 |
  • You should check that your source bundle builds, 73 | including the haddock documentation if it's a library. 74 |
  • Categories are determined by whatever you put in the Category field 75 | (there's no agreed list of category names yet). 76 | You can have more than one category, separated by commas. If no other versions of 77 | the package exist, the categories automatically become the package's tags. 78 |
  • Documentation for library packages should be generated by a maintainer. 79 | The means of doing this is still up in the air. 80 |
  • We have moved to Haddock 2, and expect some glitches. 81 | If you notice anything broken, please report it on the 82 | Haddock bug tracker. 83 |
  • In GHC 6.8, several modules were split from the base package 84 | into other packages. 85 | See these notes on making packages work with a range of versions of GHC. 86 |
  • While Haddock 2 87 | accepts GHC features, it is also more picky about comment syntax than 88 | the old version. 89 |
90 | 91 |
92 | 93 | -------------------------------------------------------------------------------- /tests/TarCheck.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Server.Upload (unpackPackage) 2 | import qualified Data.ByteString.Lazy as BS 3 | 4 | import System.Environment (getArgs) 5 | import System.FilePath (takeFileName) 6 | 7 | main = do 8 | files <- getArgs 9 | sequence_ 10 | [ do tar <- BS.readFile file 11 | case unpackPackage (takeFileName file) tar of 12 | Left err -> do 13 | putStrLn $ "FAILED! " ++ takeFileName file 14 | putStr $ err ++ "\n\n" 15 | Right (pkg, []) -> return () 16 | Right (pkg, warnings) -> do 17 | putStrLn $ "Warnings " ++ takeFileName file 18 | putStrLn (unlines warnings) 19 | | file <- files ] 20 | --------------------------------------------------------------------------------