Migrate Text instances to Pretty/Parsec (part 1)

We've got about a dozen Text instances in hackage-server that need
migration

Distribution/Server/Features/Distro/Types.hs

@@ -22,6 +22,9 @@ import Distribution.Package
 import Control.Applicative ((<$>))
 
 import Distribution.Text (Text(..))
+import Distribution.Pretty (Pretty(..))
+import Distribution.Parsec.Class (Parsec(..))
+import qualified Distribution.Compat.CharParsing as P
 
 import qualified Distribution.Compat.ReadP as Parse
 import qualified Text.PrettyPrint          as Disp
@@ -35,10 +38,16 @@ import Data.Typeable
 newtype DistroName = DistroName String
  deriving (Eq, Ord, Read, Show, Typeable, MemSize)
 
+-- TODO: remove this instance for Cabal 3.0
 instance Text DistroName where
   disp (DistroName name) = Disp.text name
   parse = DistroName <$> Parse.munch1 (\c -> Char.isAlphaNum c || c `elem` "-_()[]{}=$,;")
 
+instance Pretty DistroName where
+  pretty (DistroName name) = Disp.text name
+
+instance Parsec DistroName where
+  parsec = DistroName <$> P.munch1 (\c -> Char.isAlphaNum c || c `elem` "-_()[]{}=$,;")
 
 -- | Listing of known distirbutions and their maintainers
 data Distributions = Distributions {

Distribution/Server/Users/AuthToken.hs

@@ -22,6 +22,9 @@ import qualified Data.Text.Encoding as T
 import qualified Data.ByteString.Short as BSS
 import qualified Data.ByteString.Base16 as BS16
 import qualified Crypto.Hash.SHA256 as SHA256
+import Distribution.Pretty (Pretty(..))
+import Distribution.Parsec.Class (Parsec(..))
+import qualified Distribution.Compat.CharParsing as P
 
 import Control.Applicative ((<$>))
 import Data.SafeCopy
@@ -72,6 +75,7 @@ parseAuthToken t
 renderAuthToken :: AuthToken -> T.Text
 renderAuthToken (AuthToken bss) = T.decodeUtf8 $ BS16.encode $ BSS.fromShort bss
 
+-- TODO: remove this instance for Cabal 3.0
 instance Text AuthToken where
     disp tok = Disp.text . T.unpack . renderAuthToken $ tok
     parse =
@@ -80,6 +84,16 @@ instance Text AuthToken where
           Left err -> fail err
           Right ok -> return ok
 
+instance Parsec AuthToken where
+    parsec =
+        P.munch1 Char.isHexDigit >>= \x ->
+        case parseAuthToken (T.pack x) of
+          Left err -> fail err
+          Right ok -> return ok
+
+instance Pretty AuthToken where
+    pretty = Disp.text . T.unpack . renderAuthToken
+
 instance SafeCopy AuthToken where
     putCopy (AuthToken bs) = contain $ safePut (BSS.fromShort bs)
     getCopy =

Distribution/Server/Users/Types.hs

@@ -14,10 +14,17 @@ import Distribution.Text
          ( Text(..) )
 import qualified Distribution.Server.Util.Parse as Parse
 import qualified Distribution.Compat.ReadP as Parse
+import Distribution.Pretty (Pretty(..))
+import Distribution.Parsec.Class (Parsec(..))
+import qualified Distribution.Parsec.Class as P
+import qualified Distribution.Compat.Parsing as P
+import qualified Distribution.Compat.CharParsing as P
+
 import qualified Text.PrettyPrint          as Disp
 import qualified Data.Char as Char
 import qualified Data.Text as T
 import qualified Data.Map as M
+import qualified Data.List as L
 
 import Control.Applicative ((<$>))
 import Data.Aeson (ToJSON, FromJSON)
@@ -27,7 +34,7 @@ import Data.Hashable
 
 
 newtype UserId = UserId Int
-  deriving (Eq, Ord, Read, Show, Typeable, MemSize, ToJSON, FromJSON)
+  deriving (Eq, Ord, Read, Show, Typeable, MemSize, ToJSON, FromJSON, Pretty)
 
 newtype UserName  = UserName String
   deriving (Eq, Ord, Read, Show, Typeable, MemSize, ToJSON, FromJSON, Hashable)
@@ -62,14 +69,37 @@ instance MemSize UserStatus where
 instance MemSize UserAuth where
     memSize (UserAuth a) = memSize1 a
 
+-- TODO: remove this instance for Cabal 3.0
 instance Text UserId where
     disp (UserId uid) = Disp.int uid
     parse = UserId <$> Parse.int
 
+instance Parsec UserId where
+  -- parse a non-negative integer. No redundant leading zeros allowed.
+  -- (this is effectively a relabeled versionDigitParser)
+  parsec = (P.some d >>= (fmap UserId . toNumber)) P.<?> "UserId (natural number without redunant leading zeroes)"
+    where
+      toNumber :: P.CabalParsing m => [Int] -> m Int
+      toNumber [0]   = return 0
+      toNumber (0:_) = P.unexpected "UserId with redundant leading zero"
+      -- TODO: Add sanity check this doesn't overflow
+      toNumber xs    = return $ L.foldl' (\a b -> a * 10 + b) 0 xs
+
+      d :: P.CharParsing m => m Int
+      d = f <$> P.satisfyRange '0' '9'
+      f c = Char.ord c - Char.ord '0'
+
+-- TODO: remove this instance for Cabal 3.0
 instance Text UserName where
     disp (UserName name) = Disp.text name
     parse = UserName <$> Parse.munch1 isValidUserNameChar
 
+instance Pretty UserName where
+  pretty (UserName name) = Disp.text name
+
+instance Parsec UserName where
+  parsec = UserName <$> P.munch1 isValidUserNameChar
+
 isValidUserNameChar :: Char -> Bool
 isValidUserNameChar c = (c < '\127' && Char.isAlphaNum c) || (c == '_')