fixing licences to actual datatypes

This commit is contained in:
nek0 2017-08-06 04:42:31 +02:00
parent aac873d080
commit 1c3fee8b24
14 changed files with 118 additions and 75 deletions

View file

@ -27,6 +27,7 @@ import Database.Persist.Sql -- (ConnectionPool, runSqlPool)
import Settings.StaticFiles import Settings.StaticFiles
import Settings import Settings
import Model import Model
import Licence
import Text.Jasmine (minifym) import Text.Jasmine (minifym)
import Text.Hamlet (hamletFile) import Text.Hamlet (hamletFile)
import Yesod.Core.Types import Yesod.Core.Types
@ -293,7 +294,7 @@ instance PersistUserCredentials User where
userUserActiveF = UserActive userUserActiveF = UserActive
uniqueUsername = UniqueUser uniqueUsername = UniqueUser
userCreate name email salt = User name name email salt "" [] False (-1) False userCreate name email salt = User name name email salt "" [] False AllRightsReserved False
instance PersistToken Token where instance PersistToken Token where
tokenTokenTokenF = TokenToken tokenTokenTokenF = TokenToken

View file

@ -103,7 +103,8 @@ adminMediumSetForm medium = Medium
<*> areq (selectField licenses) (bfs ("Licence" :: T.Text)) (Just $ mediumLicence medium) <*> areq (selectField licenses) (bfs ("Licence" :: T.Text)) (Just $ mediumLicence medium)
<* bootstrapSubmit ("Change settings" :: BootstrapSubmit Text) <* bootstrapSubmit ("Change settings" :: BootstrapSubmit Text)
where where
licenses = optionsPairs $ map (\a -> (T.pack (show (toEnum a :: Licence)), a)) [-2..6] licenses = optionsPairs $ map (\a -> (T.pack (show (a :: Licence)), a))
[minBound..maxBound]
getAdminMediumDeleteR :: MediumId -> Handler Html getAdminMediumDeleteR :: MediumId -> Handler Html
getAdminMediumDeleteR mediumId = do getAdminMediumDeleteR mediumId = do

View file

@ -142,7 +142,8 @@ adminProfileForm owner = User
<*> pure (userActive owner) <*> pure (userActive owner)
<* bootstrapSubmit ("Change settings" :: BootstrapSubmit T.Text) <* bootstrapSubmit ("Change settings" :: BootstrapSubmit T.Text)
where where
licenses = optionsPairs $ map (\a -> (T.pack (show (toEnum a :: Licence)), a)) [-2..6] licenses = optionsPairs $ map (\a -> (T.pack (show (a :: Licence)), a))
[minBound..maxBound]
getAdminProfileDeleteR :: UserId -> Handler Html getAdminProfileDeleteR :: UserId -> Handler Html
getAdminProfileDeleteR ownerId = do getAdminProfileDeleteR ownerId = do

View file

@ -179,7 +179,7 @@ handleUpload
-> UserId -- ^ 'UserId' of media owner -> UserId -- ^ 'UserId' of media owner
-> Maybe Markdown -- ^ Description text -> Maybe Markdown -- ^ Description text
-> [T.Text] -- ^ Tags -> [T.Text] -- ^ Tags
-> Int -- ^ Licence -> Licence -- ^ Licence
-> UploadSpec -- ^ New file or replacement file? -> UploadSpec -- ^ New file or replacement file?
-> (Int, FileInfo) -- ^ actual file -> (Int, FileInfo) -- ^ actual file
-> Handler (Maybe T.Text) -- ^ Returns the filename if something fails -> Handler (Maybe T.Text) -- ^ Returns the filename if something fails

View file

@ -63,8 +63,8 @@ getMediumR mediumId = do
(drop 2 $ map T.pack $ splitDirectories $ mediumPreview medium) [] (drop 2 $ map T.pack $ splitDirectories $ mediumPreview medium) []
ir = StaticR $ StaticRoute ir = StaticR $ StaticRoute
(drop 2 $ map T.pack $ splitDirectories $ mediumPath medium) [] (drop 2 $ map T.pack $ splitDirectories $ mediumPath medium) []
lic = T.pack $ show (toEnum (mediumLicence medium) :: Licence) lic = T.pack $ show $ mediumLicence medium
link = url (toEnum (mediumLicence medium) :: Licence) link = url $ mediumLicence medium
defaultLayout $ do defaultLayout $ do
setTitle $ toHtml ("Eidolon :: Medium " `T.append` (mediumTitle medium)) setTitle $ toHtml ("Eidolon :: Medium " `T.append` (mediumTitle medium))
rssLink (CommentFeedRssR mediumId) $ rssLink (CommentFeedRssR mediumId) $

View file

@ -85,7 +85,7 @@ data MediumSettings = MediumSettings
, msData :: Maybe FileInfo , msData :: Maybe FileInfo
, msDescription :: Maybe Markdown , msDescription :: Maybe Markdown
, msTags :: [T.Text] , msTags :: [T.Text]
, msLicence :: Int , msLicence :: Licence
} }
mediumSettingsForm :: Medium -> AForm Handler MediumSettings mediumSettingsForm :: Medium -> AForm Handler MediumSettings
@ -97,7 +97,8 @@ mediumSettingsForm medium = MediumSettings
<*> areq (selectField licences) (bfs ("Licence" :: T.Text)) (Just $ mediumLicence medium) <*> areq (selectField licences) (bfs ("Licence" :: T.Text)) (Just $ mediumLicence medium)
<* bootstrapSubmit ("Change settings" :: BootstrapSubmit T.Text) <* bootstrapSubmit ("Change settings" :: BootstrapSubmit T.Text)
where where
licences = optionsPairs $ map (\a -> (T.pack (show (toEnum a :: Licence)), a)) [-2..6] licences = optionsPairs $ map (\a -> (T.pack (show (a :: Licence)), a))
[minBound..maxBound]
getMediumDeleteR :: MediumId -> Handler Html getMediumDeleteR :: MediumId -> Handler Html
getMediumDeleteR mediumId = do getMediumDeleteR mediumId = do

View file

@ -73,4 +73,5 @@ profileSettingsForm user = User
<*> pure (userActive user) <*> pure (userActive user)
<* bootstrapSubmit ("Change settings" :: BootstrapSubmit Text) <* bootstrapSubmit ("Change settings" :: BootstrapSubmit Text)
where where
licences = optionsPairs $ map (\a -> (T.pack (show (toEnum a :: Licence)), a)) [-2..6] licences = optionsPairs $ map (\a -> (T.pack (show (a :: Licence)), a))
[minBound..maxBound]

View file

@ -194,7 +194,7 @@ mediumToEntry ent = do
, feedEntryTitle = mediumTitle (entityVal ent) , feedEntryTitle = mediumTitle (entityVal ent)
, feedEntryContent = toHtml ((fromMaybe (Markdown "") $ mediumDescription $ entityVal ent) , feedEntryContent = toHtml ((fromMaybe (Markdown "") $ mediumDescription $ entityVal ent)
`mappend` Markdown (LT.pack "\n\n") `mappend` Markdown (LT.pack "\n\n")
`mappend` Markdown (LT.pack $ show $ (toEnum $ mediumLicence (entityVal ent) :: Licence))) `mappend` Markdown (LT.pack $ show $ mediumLicence $ entityVal ent))
, feedEntryEnclosure = Just $ EntryEnclosure , feedEntryEnclosure = Just $ EntryEnclosure
(StaticR $ StaticRoute (drop 2 $ map T.pack $ splitDirectories $ mediumPreview $ entityVal ent) []) (StaticR $ StaticRoute (drop 2 $ map T.pack $ splitDirectories $ mediumPreview $ entityVal ent) [])
size size

View file

@ -117,7 +117,8 @@ dUploadForm userId user albumId = FileBulk
<*> areq (selectField licences) (bfs ("Licence" :: T.Text)) (defLicence) <*> areq (selectField licences) (bfs ("Licence" :: T.Text)) (defLicence)
<* bootstrapSubmit ("Upload" :: BootstrapSubmit T.Text) <* bootstrapSubmit ("Upload" :: BootstrapSubmit T.Text)
where where
licences = optionsPairs $ I.map (\a -> (T.pack (show (toEnum a :: Licence)), a)) [-2..6] licences = optionsPairs $ I.map (\a -> (T.pack (show a), (a :: Licence)))
[minBound..maxBound]
defLicence = Just $ userDefaultLicence user defLicence = Just $ userDefaultLicence user
@ -129,7 +130,7 @@ data FileBulk = FileBulk
, fileBulkDesc :: Maybe Markdown , fileBulkDesc :: Maybe Markdown
, fileBulkTags :: [T.Text] , fileBulkTags :: [T.Text]
, fileBulkAlbum :: AlbumId , fileBulkAlbum :: AlbumId
, fileBulkLicence :: Int , fileBulkLicence :: Licence
} }
getUploadR :: Handler Html getUploadR :: Handler Html
@ -174,7 +175,8 @@ bulkUploadForm userId user = (\a b c d e f g h -> FileBulk b c d e f g a h)
else Nothing else Nothing
) allEnts ) allEnts
optionsPairs $ I.map (\alb -> (albumTitle $ entityVal alb, entityKey alb)) entities optionsPairs $ I.map (\alb -> (albumTitle $ entityVal alb, entityKey alb)) entities
licences = optionsPairs $ I.map (\a -> (T.pack (show (toEnum a :: Licence)), a)) [-2..6] licences = optionsPairs $ I.map (\a -> (T.pack (show a), (a :: Licence)))
[minBound..maxBound]
defLicence = Just $ userDefaultLicence user defLicence = Just $ userDefaultLicence user
postUploadR :: Handler Html postUploadR :: Handler Html

View file

@ -36,6 +36,7 @@ import Settings.StaticFiles as Import
-- custom imports -- custom imports
import Helper as Import import Helper as Import
import Licence as Import
-- end custom imports -- end custom imports

92
Licence.hs Executable file
View file

@ -0,0 +1,92 @@
-- eidolon -- A simple gallery in Haskell and Yesod
-- Copyright (C) 2015 Amedeo Molnár
--
-- This program is free software: you can redistribute it and/or modify
-- it under the terms of the GNU Affero General Public License as published
-- by the Free Software Foundation, either version 3 of the License, or
-- (at your option) any later version.
--
-- This program is distributed in the hope that it will be useful,
-- but WITHOUT ANY WARRANTY; without even the implied warranty of
-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-- GNU Affero General Public License for more details.
--
-- You should have received a copy of the GNU Affero General Public License
-- along with this program. If not, see <http://www.gnu.org/licenses/>.
module Licence where
import ClassyPrelude.Yesod
import Database.Persist.Sql
import Data.Bits (bitSizeMaybe)
class ShowUrl a where
url :: a -> Maybe String
data Licence
= PublicDomain
| AllRightsReserved
| CC0
| CCBy4
| CCBySa4
| CCByNd4
| CCByNc4
| CCByNcSa4
| CCByNcNd4
deriving (Eq, Ord, Bounded)
instance ShowUrl Licence where
url PublicDomain = Nothing
url AllRightsReserved = Nothing
url CC0 = Just "https://creativecommons.org/publicdomain/zero/1.0/"
url CCBy4 = Just "https://creativecommons.org/licenses/by/4.0"
url CCBySa4 = Just "https://creativecommons.org/licenses/by-sa/4.0"
url CCByNd4 = Just "https://creativecommons.org/licenses/by-nd/4.0"
url CCByNc4 = Just "https://creativecommons.org/licenses/by-nc/4.0"
url CCByNcSa4 = Just "https://creativecommons.org/licenses/by-nc-sa/4.0"
url CCByNcNd4 = Just "https://creativecommons.org/licenses/by-nc-nd/4.0"
instance Show Licence where
show PublicDomain = "Public Domain"
show AllRightsReserved = "All rights reserved"
show CC0 = "CC0 1.0"
show CCBy4 = "CC-BY 4.0 International"
show CCBySa4 = "CC-BY-SA 4.0 International"
show CCByNd4 = "CC-BY-ND 4.0 International"
show CCByNc4 = "CC-BY-NC 4.0 International"
show CCByNcSa4 = "CC-BY-NC-SA 4.0 International"
show CCByNcNd4 = "CC-BY-NC-ND 4.0 International"
instance Enum Licence where
fromEnum PublicDomain = -2
fromEnum AllRightsReserved = -1
fromEnum CC0 = 0
fromEnum CCBy4 = 1
fromEnum CCBySa4 = 2
fromEnum CCByNd4 = 3
fromEnum CCByNc4 = 4
fromEnum CCByNcSa4 = 5
fromEnum CCByNcNd4 = 6
fromEnum n = error $ "no licence no. for" ++ show n
toEnum (-2) = PublicDomain
toEnum (-1) = AllRightsReserved
toEnum 0 = CC0
toEnum 1 = CCBy4
toEnum 2 = CCBySa4
toEnum 3 = CCByNd4
toEnum 4 = CCByNc4
toEnum 5 = CCByNcSa4
toEnum 6 = CCByNcNd4
toEnum n = error $ "No licence no. " ++ show n
instance PersistField Licence where
toPersistValue = PersistInt64 . fromIntegral . fromEnum
fromPersistValue (PersistInt64 i) = Right $ toEnum $ fromIntegral i
fromPersistValue _ = Left "Licence is to be read form PersistInt"
instance PersistFieldSql Licence where
sqlType _
| Just x <- bitSizeMaybe (0 :: Int), x <= 32 = SqlInt32
| otherwise = SqlInt64

View file

@ -19,8 +19,9 @@ module Model where
import ClassyPrelude.Yesod import ClassyPrelude.Yesod
import Database.Persist.Quasi import Database.Persist.Quasi
import Text.Markdown import Text.Markdown
import Yesod.Text.Markdown import Yesod.Text.Markdown ()
import qualified System.FilePath as FP import qualified System.FilePath as FP
import Licence
-- You can define all of your database entities in the entities file. -- You can define all of your database entities in the entities file.
-- You can find more information on persistent and how to declare entities -- You can find more information on persistent and how to declare entities
@ -28,62 +29,3 @@ import qualified System.FilePath as FP
-- http://www.yesodweb.com/book/persistent/ -- http://www.yesodweb.com/book/persistent/
share [mkPersist sqlSettings, mkMigrate "migrateAll"] share [mkPersist sqlSettings, mkMigrate "migrateAll"]
$(persistFileWith lowerCaseSettings "config/models") $(persistFileWith lowerCaseSettings "config/models")
class ShowUrl a where
url :: a -> Maybe String
data Licence
= AllRightsReserved
| CC0
| CCBy4
| CCBySa4
| CCByNd4
| CCByNc4
| CCByNcSa4
| CCByNcNd4
| PublicDomain
instance ShowUrl Licence where
url PublicDomain = Nothing
url AllRightsReserved = Nothing
url CC0 = Just "https://creativecommons.org/publicdomain/zero/1.0/"
url CCBy4 = Just "https://creativecommons.org/licenses/by/4.0"
url CCBySa4 = Just "https://creativecommons.org/licenses/by-sa/4.0"
url CCByNd4 = Just "https://creativecommons.org/licenses/by-nd/4.0"
url CCByNc4 = Just "https://creativecommons.org/licenses/by-nc/4.0"
url CCByNcSa4 = Just "https://creativecommons.org/licenses/by-nc-sa/4.0"
url CCByNcNd4 = Just "https://creativecommons.org/licenses/by-nc-nd/4.0"
instance Show Licence where
show PublicDomain = "Public Domain"
show AllRightsReserved = "All rights reserved"
show CC0 = "CC0 1.0"
show CCBy4 = "CC-BY 4.0 International"
show CCBySa4 = "CC-BY-SA 4.0 International"
show CCByNd4 = "CC-BY-ND 4.0 International"
show CCByNc4 = "CC-BY-NC 4.0 International"
show CCByNcSa4 = "CC-BY-NC-SA 4.0 International"
show CCByNcNd4 = "CC-BY-NC-ND 4.0 International"
instance Enum Licence where
fromEnum PublicDomain = -2
fromEnum AllRightsReserved = -1
fromEnum CC0 = 0
fromEnum CCBy4 = 1
fromEnum CCBySa4 = 2
fromEnum CCByNd4 = 3
fromEnum CCByNc4 = 4
fromEnum CCByNcSa4 = 5
fromEnum CCByNcNd4 = 6
fromEnum n = error $ "no licence no. for" ++ show n
toEnum (-2) = PublicDomain
toEnum (-1) = AllRightsReserved
toEnum 0 = CC0
toEnum 1 = CCBy4
toEnum 2 = CCBySa4
toEnum 3 = CCByNd4
toEnum 4 = CCByNc4
toEnum 5 = CCByNcSa4
toEnum 6 = CCByNcNd4
toEnum n = error $ "No licence no. " ++ show n

View file

@ -22,7 +22,7 @@ User
salted ByteString salted ByteString
albums [AlbumId] albums [AlbumId]
admin Bool admin Bool
defaultLicence Int default=-1 defaultLicence Licence default=-1
active Bool default=True active Bool default=True
UniqueUser name UniqueUser name
deriving Typeable Eq Show deriving Typeable Eq Show
@ -54,7 +54,7 @@ Medium
tags Texts tags Texts
album AlbumId album AlbumId
preview FP.FilePath preview FP.FilePath
licence Int default=-1 licence Licence default=-1
deriving Eq Show deriving Eq Show
Comment Comment
author UserId author UserId

View file

@ -26,6 +26,7 @@ library
exposed-modules: Application exposed-modules: Application
Foundation Foundation
Helper Helper
Licence
Import Import
Model Model
Scale Scale