768eaec573
Motivation: these were the last things requiring a database. Once this is gone, it simplifies deployment dramatically. I'm also not sure that the social features were really worth keeping.
155 lines
5.4 KiB
Haskell
155 lines
5.4 KiB
Haskell
module Types where
|
|
|
|
import ClassyPrelude.Yesod
|
|
import Data.Aeson
|
|
import Data.Hashable (hashUsing)
|
|
import Text.Blaze (ToMarkup)
|
|
import Database.Persist.Sql (PersistFieldSql (sqlType))
|
|
import qualified Data.Text as T
|
|
import qualified Data.Text.Lazy.Builder.Int as Builder
|
|
import qualified Data.Text.Lazy.Builder as Builder
|
|
import qualified Data.Text.Lazy as LText
|
|
import qualified Data.Text.Read as Reader
|
|
|
|
newtype LtsMajor = LtsMajor Int
|
|
deriving (Eq, Read, Show)
|
|
instance PathPiece LtsMajor where
|
|
toPathPiece (LtsMajor x) = "lts-" ++ tshow x
|
|
fromPathPiece t0 = do
|
|
t1 <- stripPrefix "lts-" t0
|
|
Right (x, "") <- Just $ Reader.decimal t1
|
|
Just $ LtsMajor x
|
|
|
|
newtype PackageName = PackageName { unPackageName :: Text }
|
|
deriving (Show, Read, Typeable, Eq, Ord, Hashable, PathPiece, ToMarkup, PersistField, IsString)
|
|
instance PersistFieldSql PackageName where
|
|
sqlType = sqlType . liftM unPackageName
|
|
newtype Version = Version { unVersion :: Text }
|
|
deriving (Show, Read, Typeable, Eq, Ord, Hashable, PathPiece, ToMarkup, PersistField)
|
|
instance PersistFieldSql Version where
|
|
sqlType = sqlType . liftM unVersion
|
|
newtype PackageSetIdent = PackageSetIdent { unPackageSetIdent :: Text }
|
|
deriving (Show, Read, Typeable, Eq, Ord, Hashable, PathPiece, ToMarkup, PersistField)
|
|
instance PersistFieldSql PackageSetIdent where
|
|
sqlType = sqlType . liftM unPackageSetIdent
|
|
|
|
data PackageNameVersion = PNVTarball !PackageName !Version
|
|
| PNVNameVersion !PackageName !Version
|
|
| PNVName !PackageName
|
|
deriving (Show, Read, Typeable, Eq, Ord)
|
|
|
|
instance PathPiece PackageNameVersion where
|
|
toPathPiece (PNVTarball x y) = concat [toPathPiece x, "-", toPathPiece y, ".tar.gz"]
|
|
toPathPiece (PNVNameVersion x y) = concat [toPathPiece x, "-", toPathPiece y]
|
|
toPathPiece (PNVName x) = toPathPiece x
|
|
fromPathPiece t' | Just t <- stripSuffix ".tar.gz" t' =
|
|
case T.breakOnEnd "-" t of
|
|
("", _) -> Nothing
|
|
(_, "") -> Nothing
|
|
(T.init -> name, version) -> Just $ PNVTarball (PackageName name) (Version version)
|
|
fromPathPiece t = Just $
|
|
case T.breakOnEnd "-" t of
|
|
("", _) -> PNVName (PackageName t)
|
|
(T.init -> name, version) | validVersion version ->
|
|
PNVNameVersion (PackageName name) (Version version)
|
|
_ -> PNVName (PackageName t)
|
|
where
|
|
validVersion =
|
|
all f
|
|
where
|
|
f c = (c == '.') || ('0' <= c && c <= '9')
|
|
|
|
newtype HoogleVersion = HoogleVersion Text
|
|
deriving (Show, Eq, Ord, Typeable, PathPiece)
|
|
currentHoogleVersion :: HoogleVersion
|
|
currentHoogleVersion = HoogleVersion VERSION_hoogle
|
|
|
|
data UnpackStatus = USReady
|
|
| USBusy
|
|
| USFailed !Text
|
|
|
|
data StackageExecutable
|
|
= StackageWindowsExecutable
|
|
| StackageUnixExecutable
|
|
deriving (Show, Read, Eq)
|
|
|
|
instance PathPiece StackageExecutable where
|
|
-- TODO: distribute stackage, not just stackage-setup
|
|
toPathPiece StackageWindowsExecutable = "stackage-setup.exe"
|
|
toPathPiece StackageUnixExecutable = "stackage-setup"
|
|
|
|
fromPathPiece "stackage-setup" = Just StackageUnixExecutable
|
|
fromPathPiece "stackage-setup.exe" = Just StackageWindowsExecutable
|
|
fromPathPiece _ = Nothing
|
|
|
|
data GhcMajorVersion = GhcMajorVersion !Int !Int
|
|
deriving (Eq)
|
|
|
|
data GhcMajorVersionFailedParse = GhcMajorVersionFailedParse Text
|
|
deriving (Show, Typeable)
|
|
instance Exception GhcMajorVersionFailedParse
|
|
|
|
ghcMajorVersionToText :: GhcMajorVersion -> Text
|
|
ghcMajorVersionToText (GhcMajorVersion a b)
|
|
= LText.toStrict
|
|
$ Builder.toLazyText
|
|
$ Builder.decimal a <> "." <> Builder.decimal b
|
|
|
|
ghcMajorVersionFromText :: MonadThrow m => Text -> m GhcMajorVersion
|
|
ghcMajorVersionFromText t = case Reader.decimal t of
|
|
Right (a, T.uncons -> Just ('.', t')) -> case Reader.decimal t' of
|
|
Right (b, t'') | T.null t'' -> return $ GhcMajorVersion a b
|
|
_ -> failedParse
|
|
_ -> failedParse
|
|
where
|
|
failedParse = throwM $ GhcMajorVersionFailedParse t
|
|
|
|
instance PersistFieldSql GhcMajorVersion where
|
|
sqlType = sqlType . liftM ghcMajorVersionToText
|
|
|
|
instance PersistField GhcMajorVersion where
|
|
toPersistValue = toPersistValue . ghcMajorVersionToText
|
|
fromPersistValue v = do
|
|
t <- fromPersistValueText v
|
|
case ghcMajorVersionFromText t of
|
|
Just ver -> return ver
|
|
Nothing -> Left $ "Cannot convert to GhcMajorVersion: " <> t
|
|
|
|
instance Hashable GhcMajorVersion where
|
|
hashWithSalt = hashUsing ghcMajorVersionToText
|
|
|
|
instance FromJSON GhcMajorVersion where
|
|
parseJSON = withText "GhcMajorVersion" $
|
|
either (fail . show) return . ghcMajorVersionFromText
|
|
|
|
instance ToJSON GhcMajorVersion where
|
|
toJSON = toJSON . ghcMajorVersionToText
|
|
|
|
|
|
data SupportedArch
|
|
= Win32
|
|
| Win64
|
|
| Linux32
|
|
| Linux64
|
|
| Mac32
|
|
| Mac64
|
|
deriving (Enum, Bounded, Show, Read, Eq)
|
|
|
|
instance Hashable SupportedArch where
|
|
hashWithSalt = hashUsing fromEnum
|
|
|
|
instance PathPiece SupportedArch where
|
|
toPathPiece Win32 = "win32"
|
|
toPathPiece Win64 = "win64"
|
|
toPathPiece Linux32 = "linux32"
|
|
toPathPiece Linux64 = "linux64"
|
|
toPathPiece Mac32 = "mac32"
|
|
toPathPiece Mac64 = "mac64"
|
|
|
|
fromPathPiece "win32" = Just Win32
|
|
fromPathPiece "win64" = Just Win64
|
|
fromPathPiece "linux32" = Just Linux32
|
|
fromPathPiece "linux64" = Just Linux64
|
|
fromPathPiece "mac32" = Just Mac32
|
|
fromPathPiece "mac64" = Just Mac64
|
|
fromPathPiece _ = Nothing
|